Copy rows to other sheets in the same workbook depending on a condition in one column.

[Violet2802]

<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993}span.s1 {color: #011993}span.s2 {color: #000000}</style>Hi,

I am trying to use VBA to copy rows from the master spreadsheet into the corresponding tabs (EMAS/EEAST/YAS/SWAST/WAST) depending on the condition in a specific column (D). The first part of my code works and copies data that includes the term "EMAS" into the appropriate sheet. However, the additional 4 sheets will not populate with their specific terms. What am I doing wrong with the code? I am very new to this so it's hopefully very basic. I have arbitrarily given the worksheets identifying letters, I don't know if that's okay. It seems to have worked for the EMAS tab, but no others!

Sub Button1_Click()
Set i = Sheets("MASTER")
Set e = Sheets("EMAS")
Set b = Sheets("EEAST")
Set c = Sheets("YAS")
Set f = Sheets("SWAST")
Set g = Sheets("WAST")

Dim d
Dim j
d = 1
j = 2

Do Until IsEmpty(i.Range("D" & j))

If i.Range("D" & j) = "EMAS" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop

Do Until IsEmpty(i.Range("D" & j))

If i.Range("D" & j) = "EEAST" Then
d = d + 1
b.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop

Do Until IsEmpty(i.Range("D" & j))

If i.Range("D" & j) = "YAS" Then
d = d + 1
c.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop

Do Until IsEmpty(i.Range("D" & j))

If i.Range("D" & j) = "SWAST" Then
d = d + 1
f.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop

Do Until IsEmpty(i.Range("D" & j))

If i.Range("D" & j) = "WAST" Then
d = d + 1
g.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1

Loop
End Sub

Many Thanks!

 

[My Aswer Is This]

So you want the entire row in the sheet named "Master".
Copied to the sheet name in column "D" is that correct?

So if "George" is in Column "D" that row will be copied into the next empty row of sheet named "George"
And all the sheets have already been created.

 

[JackDanIce]

Hi, welcome to the board.

Untested (so try on a copy of the workbook first), however, replace above with all over below and see if it works (reply back if any errors):

Sub Button1_Click()
'Main code

    'Variables
    Dim LR      As Long
    Dim x       As Long
    Dim y       As Long
    Dim wkb     As Worksheet
    Dim arr()   As Variant
    
    Application.ScreenUpdating = False
    
    'Assuming button is on the sheet currently visitble
    With ActiveSheet
        'Find last row in column D
        LR = LastRow(ActiveSheet, 4)
        
        'Loop through A2:ALR
        For x = 2 To LR
            With .Cells(x, 1)
                'Find last column used in row x
                y = .Cells(1, .Columns.Count).End(xlToLeft).Column
                'Read data to an array
                arr = .Resize(, y).Value
                'Write array to sheet via function CopyValues, using .Offset to read value in Dx if Looping through A2:Ax
                CopyValues .Offset(, 3).Value, arr
            End With
            'Clear array
            Erase arr
        Next x
    End With
    
    Application.ScreenUpdating = False
    
End Sub

Private Sub CopyValues(ByRef wksName As String, ByRef arr() As Variant)
'Code to copy to sheet as specified by argument wksName, with data in array as argument arr

    'Variables
    Dim wks     As Worksheet
    Dim LR      As Long
    
    'Test if worksheet exists
    On Error Resume Next
        Set wks = Sheets(wksName)
    On Error GoTo 0
    
    'If worksheet exists, write array data to first empty row after last used row in column 1 ("A")
    If Not wks Is Nothing Then
        With Sheets(wksName)
            LR = LastRow(wks, 1) + 1
            .Cells(LR, 1).Resize(, UBound(arr, 2)).Value = arr
        End With
        Set wks = Nothing
    End If
    
End Sub

Private Function LastRow(ByRef wks As Worksheet, ByRef Col As Long) As Long
'Code to find last used row in specified sheet and column

    With wks
        LastRow = .Cells(.Rows.Count, Col).End(xlUp).row
    End With
    
End Function

 

[My Aswer Is This]

If the answers to my question in post #2 are yes.
Try this.

Sub Test()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Sheets("Master").Activate
Lastrow = Sheets("Master").Cells(Rows.Count, "D").End(xlUp).Row
For i = 1 To Lastrow
Lastrowa = Sheets(Cells(i, "D").Value).Cells(Rows.Count, "D").End(xlUp).Row + 1
Rows(i).Copy Destination:=Sheets(Cells(i, "D").Value).Rows(Lastrowa)
Next
Application.ScreenUpdating = True
End Sub

 

[Violet2802]

Hi, thank you for your quick reply. Yes, in your example if 'George' is in column D in the master sheet, then I would like the whole row copied to the sheet of the same name. As I said originally, it seems to copy the first item in my code (EMAS) but the following ones do not work so I am doing something wrong. When I try the code above it tells me that: click button cannot be found.

 

[JackDanIce]

You need to replace all of your existing code with my code for post #3 - for the button on your existing sheet.

 

[My Aswer Is This]

You need to show me the exact script your using now. I suspect you are putting my script into a button which has some other code already.

Hi, thank you for your quick reply. Yes, in your example if 'George' is in column D in the master sheet, then I would like the whole row copied to the sheet of the same name. As I said originally, it seems to copy the first item in my code (EMAS) but the following ones do not work so I am doing something wrong. When I try the code above it tells me that: click button cannot be found.