Home » excel » excel – VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information

excel – VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information

Posted by: admin May 14, 2020 Leave a comment

Questions:

VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information
Hey all- I’m trying to a script that identifies the unique values in column E (data starts on row 1), creates a new sheet based on those unique values (also names the sheet per the value), and in the new sheet it creates it brings over the information corresponding rows in column A, C, D, and H –

I found this YouTube video that shows the process but instead of the script indentifying the unique values you have to manually input the keyword it is looking for and it only runs it once. I haven’t been able to get the ‘for loop’ to run properly …

https://www.youtube.com/watch?v=qGZQIl9JJk4&t=561s

Any help would be much appreciated-!

Private Sub CommandButton1_Click()

J = "Test"
Worksheets.Add().Name = J
Worksheets("Sheet1").Rows(1).Copy
Worksheets(J).Activate
ActiveSheet.Paste
Worksheets("Sheet1").Activate


a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To a
If Worksheets("Sheet1").Cells(i, 5).Value = "XXXX" Then

    Worksheets("Sheet1").Rows(i).Copy
    Worksheets(J).Activate
    b = Worksheets(J).Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets(J).Cells(b + 1, 1).Select
    ActiveSheet.Paste
    Worksheets("Sheet1").Activate

End If
Next

Application.CutCopyMode = False

ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select

End Sub
How to&Answers:

Something like this:

Private Sub CommandButton1_Click()

    Dim sht As Worksheet,  c As Range, i As Long
    Set sht = ThisWorkbook.Worksheets("Sheet1")

    For i = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row

        CopyDestination(sht.Cells(i, 5).Value).Resize(1, 5).Value = _
           Array(sht.Cells(i, 5).Value, sht.Cells(i, 1).Value, _
                 sht.Cells(i, 3).Value, sht.Cells(i, 4).Value, _
                 sht.Cells(i, 8).Value)

    Next

    Application.CutCopyMode = False

End Sub


'Find the next "paste" destination on the appropriate sheet named "v"
'   If sheet doesn't exist, create it
Function CopyDestination(v) As Range
    Dim sht As Worksheet
    On Error Resume Next
    Set sht = ThisWorkbook.Sheets(v)
    On Error GoTo 0
    If sht Is Nothing Then '<< no existing matching sheet
        With ThisWorkbook
            Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
        End With
        sht.Name = v  '<<< assumes "v" is valid as a worksheet name...
    End If
    'find the first empty cell in Col A
    Set CopyDestination = sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Function