Rearranging data

[John Pierce]

I've been given some data that looks like this:
Name Docs
Name1 doc1
Name1 doc3
Name2 doc2
Name2 doc3
Name3 doc1
Name4 doc1
Name4 doc2
Name4 doc3
Name5 doc1
Name5 doc3
Name6 doc3

and I need it to look like this:

Name Doc1 Doc2 Doc3
Name1 X X
Name2 X X
Name3 X
Name4 X X X
Name5 X X
Name6 X

There are thousands of records but only three different doc types.
For each Name, all three docs might be there, or only one, or
any combination of two of them.

 

[OssieMac]

Hi John,

try this.

Sub Rearrange()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rngNames As Range
Dim colNames As String
Dim c As Range
Dim saveName As String
Dim offSetCol As Long

Set ws1 = Sheets("Sheet1") 'Edit with original list sheet name
Set ws2 = Sheets("Sheet2") 'Edit with your Output sheet name

colNames = "A" 'Edit to your column of names

With ws1
Set rngNames = Range(.Cells(2, colNames), _
.Cells(.Rows.Count, colNames).End(xlUp))
End With

With ws2
.Cells(1, "A") = "Name"
.Cells(1, "B") = "Doc1"
.Cells(1, "C") = "Doc2"
.Cells(1, "D") = "Doc3"
End With

For Each c In rngNames
If c.Value <> saveName Then
With ws2
.Cells(.Rows.Count, "A").End(xlUp). _
Offset(1, 0) = c.Value
saveName = c.Value
End With
End If
If c.Offset(0, 1) <> "" Then
Select Case Right(c.Offset(0, 1), 1)
Case 1
offSetCol = 1
Case 2
offSetCol = 2
Case 3
offSetCol = 3
End Select
With ws2
.Cells(.Rows.Count, "A").End(xlUp). _
Offset(0, offSetCol) = "X"
End With
End If
Next c

End Sub

 

[John Pierce]

HiJohn,

try this.

Sub Rearrange()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rngNames As Range
Dim colNames As String
Dim c As Range
Dim saveName As String
Dim offSetCol As Long

Set ws1 = Sheets("Sheet1")  'Edit with original list sheet name
Set ws2 = Sheets("Sheet2")  'Edit with your Output sheet name

colNames = "A"  'Edit to your column of names

With ws1
    Set rngNames = Range(.Cells(2, colNames), _
        .Cells(.Rows.Count, colNames).End(xlUp))
End With

With ws2
    .Cells(1, "A") = "Name"
    .Cells(1, "B") = "Doc1"
    .Cells(1, "C") = "Doc2"
    .Cells(1, "D") = "Doc3"
End With

For Each c In rngNames
    If c.Value <> saveName Then
        With ws2
            .Cells(.Rows.Count, "A").End(xlUp). _
                Offset(1, 0) = c.Value
            saveName = c.Value
        End With
    End If
    If c.Offset(0, 1) <> "" Then
        Select Case Right(c.Offset(0, 1), 1)
            Case 1
                offSetCol = 1
            Case 2
                offSetCol = 2
            Case 3
                offSetCol = 3
        End Select
        With ws2
            .Cells(.Rows.Count, "A").End(xlUp). _
            Offset(0, offSetCol) = "X"
        End With
    End If
Next c

End Sub

--
Regards,

OssieMac








- Show quoted text -

OssieMac, Thank you. Your procedure works perfectly.