Excel VBA宏：重新组织行并由唯一标识符分隔

Question

So, I've got this excel table which lists a bunch of record numbers and complaints made against the record.

The table is set-up unusually in that each record #'s complaints are shown on the same row as the record number.

So if a record has 10 complaints, the information about each complaint is listed (one after the other) in the same row as the record #.

I want to create a VBA macro which grabs these complaints that are all listed in the same row and separates them by record number, into their own rows. I've included a screenshot of the original table and what I imagine the output to be.

I am brand new to VBA and I think I just don't have the language to describe this problem. Can anyone help?

Original Table

Example Output

Answer 1

I hope I understood this right. Basicly you want to check each row, one after another, if there is a complaint or not. If there is a complaint, it shall be extracted into eg an other worksheet. Try to get the length of your table and then check each cell in "Complaint Date". If there is a date show the whole row in another sheet/table/etc.. This code works quite fine for this I hope.

Dim counter, lastrow As Integer
counter = 1
lastrow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row  'finds the last row in column A
For i = 1 To lastrow
    If Cells(i,2) <> "No Complaints" Then
        Cells(counter,x)    'Write the cell where you want(counter to have them one under the other)
        counter = counter + 1
    End If
Next i

Answer 2

Assuming worksheets input contains the table that all datas and you need to create empty sheet and name it as output.

Apply the below code in new module

Sub test()
    Worksheets("Input").Select
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim printatsheet2 As Long
    Dim actualset As Long
    Dim recordno As String
    Dim complaintdate As Date
    Dim walkin As String
    Dim conclusive As String
    Dim typej As String
    Dim typex As String
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
    printatoutput = Worksheets("Output").Range("A" & Rows.Count).End(xlUp).Row + 1
    actualset = (lastcolumn - 1) / 5
    For i = 2 To lastrow
        recordno = Cells(i, 1)
        For j = 1 To actualset
        If j = 1 Then
            dd = j + 1 '7 '13
            ee = (j + 5) '12 '18
        Else
            dd = dd + 5
            ee = ee + 5
        End If
            For k = dd To ee
                If Cells(1, k) = "Complaint Date" And (Cells(i, k) <> "No Complaints" And Cells(i, k) <> "") Then
                    complaintdate = Cells(i, k)
                ElseIf Cells(1, k) = "#Walkin" Then
                    walkin = Cells(i, k)
                ElseIf Cells(1, k) = "#Conclusive" Then
                    conclusive = Cells(i, k)
                ElseIf Cells(1, k) = "#TypeJ" Then
                    typej = Cells(i, k)
                ElseIf Cells(1, k) = "#TypeX" Then
                    typex = Cells(i, k)
                End If
            Next k
            If complaintdate = CDate(0) And walkin = "" And conclusive = "" And typej = "" And typex = "" Then
                'nothing
            Else
                With Worksheets("Output")
                    .Cells(printatoutput, 1) = recordno
                    .Cells(printatoutput, 2) = complaintdate
                    .Cells(printatoutput, 3) = walkin
                    .Cells(printatoutput, 4) = conclusive
                    .Cells(printatoutput, 5) = typej
                    .Cells(printatoutput, 6) = typex
                    printatoutput = printatoutput + 1
                End With
                'If complaintdate = CDate(0) Then complaintdate = CDate(0) Else complaintdate = complaintdate
                complaintdate = CDate(0)
                walkin = ""
                conclusive = ""
                typej = ""
                typex = ""
            End If
        Next j
    Next i
End Sub