VBA to copy excel worksheet, append new rows from specific columns

Question

I am using Excel to produce reports for a billing system and I would like to use VBA to simplify the process of updating the excel. What I want to do is to copy,paste and append information from columns ("A:F") in Mastersheets and separate them based on names in their respective Named worksheets. All sheets starts from row 4. (Row 3 is header)

So I'll further simplify the process as such: Starting as a new excelsheet, I would like to firstly copy and paste all of the data from mastersheet to respective Named worksheets. After that is done:

COPY, PASTE AND APPEND (When changes made in the mastersheet) 1. Select mastersheet. 2. At mastersheet, search existing sheet column(A)for bill number (in order to allow updating of only new bills to existing data) 3. Copy and paste new bill number from column ("A:F") to respective Named worksheets starting from the last empty row of each Named worksheets. (I think I've defined it in the codes, one problem with "George" sheet, it doesn't run through the entire sheet, it stops at a certain row number)

My problem now is I can't make the append function work. The copy and paste function is more or less done. Here are the codes I have so far. It's all I worked out as of now. Any help would be greatly appreciated.

' COPY, PASTE AND APPEND   
Sub Append()

Dim manager As String, lastrow As Long, i As Integer
Dim find As Range, bill As String


Set mastersheet = Sheet1

mastersheet.Select
bill = Sheet1.Range("A:A").Value
Do While Not bill = ""
Set find = Sheet1.Range("A:A").find(what:=bill, lookat:=xlValues, lookat:=xlWhole)
If find Is Nothing Then

lastrow = Cells(Rows.Count, 1).End(xlUp).row

For i = 2 To lastrow
If Cells(i, 2) = "JOHN" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheet13.Select
    Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    mastersheet.Select

    End If

Next i
For i = 2 To lastrow
If Cells(i, 2) = "CHARLIE" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheet11.Select
    Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    mastersheet.Select
    End If
Next i
For i = 2 To lastrow
If Cells(i, 2) = "GEORGE" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheet12.Select
    Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    mastersheet.Select
    End If
Next i

Else

Sheet1.Select

End If
Loop

End Sub

Please can you tend to questions you have already posted before posting new ones? It's little incentive for anyone to respond if they doubt that you will. — SJR
@SJR My apologies. I have edited my question in order to make things more clear. I didn't want to combine the questions as I thought it was going to be too long. Thank you for your time and patience. :) — Carmen

Cyril Cyril · Accepted Answer · 2017-05-26T13:01:32

I tried to clean up the code (lots of .select), first. You didn't define what your .pastespecial is printing on the paste-sheet. If you're just pasting, then you can shorten that line up and just put the paste-location on the same line as the copy-location without specifying paste; it assumes that you're just moving from location designated to a new location.

I believe in changing and removing the mastersheet.select from George's loop, it may have helped clean up that sheet. I'm not saying it is the problem, but doesn't hurt to have as such. Additionally, I gave you more defined variables, as to not have issues with saved values (i to i, j, and k).

Hopefully those changes help more than hinder!

' COPY, PASTE AND APPEND   
Sub Append()

Dim manager As String, lastrow As Long, i As Integer, k as integer, j as integer
Dim find As Range, bill As String

bill = Sheets("Sheet1").Range("A:A").Value
Do While Not bill = ""
Set find = Sheets("Sheet1").Range("A:A").find(what:=bill, lookat:=xlValues, lookat:=xlWhole)

If find Is Nothing Then

lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row

For i = 2 To lastrow
    If Cells(i, 2) = "JOHN" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheets("Sheet13").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next i

For j = 2 To lastrow
    If Sheets("Sheet1").Cells(j, 2) = "CHARLIE" Then
    Sheets("Sheet1").Range(Cells(j, 1), Cells(j, 6)).copy
    Sheets("Sheet11").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next j

For k = 2 To lastrow
    If Sheets("Sheet1").Cells(k, 2) = "GEORGE" Then
    Sheets("Sheet1").Range(Cells(k, 1), Cells(k, 6)).copy
    Sheets("Sheet12").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next k

Else

Sheets("Sheet1").Select

End If
Loop

End Sub

VBA to copy excel worksheet, append new rows from specific columns

1 Answers