Modifying a macro that splits data into ws's by column value - getting the code to paste to next blank row?

[dougmarkham]

Hi Folks,

Basic problem & goal:

I have a macro that splits data in a master worksheet into existing worksheets i.e., by reference to column 6's values (see Red text in below tables).
However, if I run it twice for different data, new data over-writes previously split data.

Context:
The worksheet "ManifestMaster" is populated by a 'product manifest' where each product is given a pallet number (Pallet 1; Pallet 2 etc).
Products can be on more than one pallet.

The main issue:
My brief is to make a macro that can be run multiple times i.e., to keep adding more products to the master manifest.
Currently, re-runs of the code are over-writing data already existing in the Pallet worksheets.

Details

For instance:
First instance: I add initial set of products to the manifest including "Product 1" that is to go on "Pallet 1"
Second instance: I add additional products to the manifest including "Product 3" that is to go on "Pallet 1"

Thus, on the second instance when I run the macro, currently it over-writes "Product 1's" row on Worksheet("Pallet 1") with "Product 3's row"

First instance
"ManifestMaster"

Product Code	Description	Quantity	UOM	Box number	Pallet Number	Load number	Location
Product 1	Sales ticket £10	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 3
Product 50	Poster A3 Deal 4	1000	Pack 25	100	Pallet 3	1	Isle 3; Bay 12
Product 8	Torch AA batteries	100	Single	5	Pallet 9	1	Isle 6; Bay 7

"Pallet 1"

Product Code	Description	Quantity	UOM	Box number	Pallet Number	Load number	Location
Product 1	Sales ticket £10	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 3

Second instance

"ManifestMaster"

Product Code	Description	Quantity	UOM	Box number	Pallet Number	Load number	Location
Product 3	Sales ticket £25	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 4
Product 23	Poster A2 Deal 1	1011	Pack 20	30	Pallet 5	1	Isle 20; Bay 18
Product 8	Banner 60 ft Summer Sale	4	Single	4	Pallet 19	1	Isle 17; Bay 1

"Pallet 1"

Product Code	Description	Quantity	UOM	Box number	Pallet Number	Load number	Location
Product 3	Sales ticket £25	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 4

What I'm aiming for:

Second instance

"ManifestMaster"

Product Code	Description	Quantity	UOM	Box number	Pallet Number	Load number	Location
Product 3	Sales ticket £25	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 4
Product 23	Poster A2 Deal 1	1011	Pack 20	30	Pallet 5	1	Isle 20; Bay 18
Product 8	Banner 60 ft Summer Sale	4	Single	4	Pallet 19	1	Isle 17; Bay 1

"Pallet 1"

Product Code	Description	Quantity	UOM	Box number	Pallet Number	Load number	Location
Product 1	Sales ticket £10	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 3
Product 3	Sales ticket £25	50	Pack 10	1	Pallet 1	1	Isle 1; Bay 4

Would anyone please help me modify the below code so copied rows don't over-write existing rows in the destination worksheet?

Here is the line which I'm trying to modify so it' doesn't put the copied rows into A2 but looks for the first available blank row in column A.

        ws.Range("A" & titlerowOffset & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A2")

Here is the full code

Sub CopyDataToPalletTabs()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual

    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim titlerowOffset As Integer
    
    'vcol designate as the 6th column i.e., Col F
    vcol = 6
    
    'Set ws
    Set ws = Sheets("ManifestMaster")
    
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    
    title = "A2:H2"
    titlerow = ws.Range(title).Cells(1).Row
    titlerowOffset = ws.Range(title).Cells(1).Offset(1, 0).Row
    
    icol = ws.Columns.Count
    
    ws.Cells(1, icol) = "Unique"
    
    For i = 3 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    'Clears the column where icol is
    ws.Columns(icol).Clear
    
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If

        ws.Range("A" & titlerow & ":A" & titlerow).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        
        THE LINE I'M TRYING TO MODIFY
        ws.Range("A" & titlerowOffset & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A2")
        

        Sheets(myarr(i) & "").Columns.AutoFit
        Call SetPageBreaks
    Next
    'Call SortWorkBook
    ws.AutoFilterMode = False
    ws.Activate
   
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
   
End Sub

Kind regards,

Doug.

 

[dougmarkham]

Hi Folks,

Just a quick note to say that I've worked it out:
For anyone interested...

        ws.Range("A" & titlerowOffset & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Cells(Rows.Count, 1).End(xlUp).Offset(1)

Sub CopyDataToPalletTabs()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual

    Dim lr As Long
    Dim Ir2 As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim titlerowOffset As Integer
    
    vcol = 6
    
    'Set ws
    Set ws = Sheets("ManifestMaster")

    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

    title = "A2:H2"
    titlerow = ws.Range(title).Cells(1).Row
    titlerowOffset = ws.Range(title).Cells(1).Offset(1, 0).Row
    
    icol = ws.Columns.Count
    
    ws.Cells(1, icol) = "Unique"
    
    For i = 3 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    'Clears the column where icol is
    ws.Columns(icol).Clear
    
    Set ws2 = Sheets(myarr(i) & "")
    Ir2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        'This line of code copies the filtered data from title row down to the last row with data in it and pastes to range("A1") in the corresponding ws matching myarr value
        ws.Range("A" & titlerow & ":A" & titlerow).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        ws.Range("A" & titlerowOffset & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        
        'Fits column width to col cell values for that worksheet [myarr(i)]
        Sheets(myarr(i) & "").Columns.AutoFit
        Call SetPageBreaks
    Next

    ws.AutoFilterMode = False
    ws.Activate
   
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
   
End Sub

Kind regards,

Doug