VBA-copy row data to corresponding sheet

Question

I was given the following table (much, much bigger but it gives the idea):

I have corresponding sheets to column A with the main table = ALLDATA

I found the following VBA code and used it to create the sheets from column A:

Sub AddSheets()
'Updateby Extendoffice
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A2:A500")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub

The table is almost 500 Rows but will be longer as new equipment is brought in to be tested.

I would like to move the row data from ALLDATA to the matching sheet number.

Actually, I would love to move the row data from ALLDATA and see it in a table of some sort in each corresponding sheet to show ultimately show the trending of the tested equipment but this is the way I have received this document. Is there a way to move row data to a table like this?

I apologize if this is extremely basic, I'm really new to excel and VBA codes so I appreciate any/all help and super appreciate your patience with me. Happy to learn as much as I can too so if you know of a good way to learn how to do this myself, I'd gratefully accept it. Oh, I should mention I'm working on a windows 10 based computer with Microsoft 365 apps for enterprise excel version 2208.

hansvogelaar · Answer

JDAV44&nbsp;
Try this (it is not the fastest, but it should work).
Sub SplitData()
    Const IDCol = "A"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim SrcBook As Workbook
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim LastRow As Long
    Dim TrgRow As Long
    Dim ID As String
    Application.ScreenUpdating = False
    Set SrcSheet = Worksheets("ALLDATA")
    LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, IDCol).End(xlUp).Row
    For SrcRow = FirstRow To LastRow
        ID = SrcSheet.Cells(SrcRow, IDCol).Value
        Set TrgSheet = Nothing
        On Error Resume Next
        Set TrgSheet = Worksheets(ID)
        On Error GoTo 0
        If TrgSheet Is Nothing Then
            Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            TrgSheet.Name = ID
            SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
        End If
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, IDCol).End(xlUp).Row + 1
        SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
    Next SrcRow
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

hansvogelaar · Answer

JDAV44&nbsp;
Are there rows with an empty ID? Or with an ID that looks very different from your screenshot?

hansvogelaar · Answer

JDAV44&nbsp;
See for example this Excel VBA Tutorial&nbsp;

hansvogelaar · Answer

JDAV44&nbsp;
This version of the macro will skip empty IDs:
Sub SplitData()
    Const IDCol = "A"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim SrcBook As Workbook
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim LastRow As Long
    Dim TrgRow As Long
    Dim ID As String
    Application.ScreenUpdating = False
    Set SrcSheet = Worksheets("ALLDATA")
    LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, IDCol).End(xlUp).Row
    For SrcRow = FirstRow To LastRow
        ID = SrcSheet.Cells(SrcRow, IDCol).Value
        If ID &lt;&gt; "" Then
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(ID)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = ID
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, IDCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        End If
    Next SrcRow
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

logaraj sekar · Answer

Have you solved this or still facing issues.?

Forum Discussion

VBA-copy row data to corresponding sheet

Share

Resources