Need Help!

[ptaylor123]

I have a spreadsheet with a consistent column of data in Column A, and the values from Column B Onwards.

Basically:

Columns
A B C D E

A 1 2 3
B 4
C 5 6 7 8
D 9 1
E 2 3 4

I need m data to look like:

A 1
A 2
A 3
B 4
C 5
C 6
C 7
C 8
D 9
D 1
E 2
E 3
E 4

I could use some help as I'm stuck! Would appreciate any help anyone can give me

Thanks,

 

[AidanTMoore]

Hi ptaylor123,

Here is how I would do it, it relies on the data starting in range("A1") and on sheet3 being empty to begin with.

Hope it helps!

Sub excel_Help()
Dim endRow As Long
Dim cell As Range
Dim firstVal As String
Dim secondVal As String
Dim colCount As Long
Dim i As Long
Dim dataRow As Long
Dim x As Long
endRow = Range("A1048576").End(xlUp).Row
Range("A1", "A" & endRow).Select
x = 0
For Each cell In Selection
    firstVal = cell.Text
        colCount = cell.End(xlToRight).Column
            For i = colCount To 2 Step -1
                x = x + 1
                secondVal = firstVal & Cells(cell.Row, i)
                Sheets("Sheet3").Range("A" & x) = secondVal
            Next i
Next cell
End Sub

 

[ptaylor123]

Fantastic, thank you so much for your help!

It worked almost perfectly - on sheet3 it put the value to look up and the result into the same cell?
Are you able to fix so the result is in column b?
Thanks J

 

[AidanTMoore]

Sure, try this:

Sub excel_Help()


Dim endRow As Long
Dim cell As Range
Dim firstVal As String
Dim secondVal As String
Dim colCount As Long
Dim i As Long
Dim x As Long


endRow = Range("A1048576").End(xlUp).Row
Range("A1", "A" & endRow).Select
x = 0
For Each cell In Selection
    firstVal = cell.Text
    colCount = cell.End(xlToRight).Column
    For i = colCount To 2 Step -1
        x = x + 1
        secondVal = Cells(cell.Row, i)
        Sheets("Sheet3").Range("A" & x) = firstVal
        Sheets("Sheet3").Range("B" & x) = secondVal
    Next i
Next cell
End Sub

 

[Peter_SSs]

I don't know how big your data is, but if it is fairly big this should be a lot faster. It also puts the results in the same order you have them in your post #1 sample.
The sheet with the original data needs to be the active sheet when the code is run.
Sheet3 needs to exists but does not need to be empty as the code clears all data from it.

Test in a copy of your workbook.

Sub MakeTable()
  Dim Data, Results, Col1
  Dim i As Long, j As Long, k As Long, ubData2 As Long
  
  ubData2 = Range("A1").CurrentRegion.Columns.Count + 1
  Data = Range("A1").CurrentRegion.Resize(, ubData2).Value
  ReDim Results(1 To UBound(Data, 1) * (ubData2 - 2), 1 To 2)
  For i = 1 To UBound(Data, 1)
    Col1 = Data(i, 1)
    j = 2
    Do
      k = k + 1
      Results(k, 1) = Col1
      Results(k, 2) = Data(i, j)
      j = j + 1
    Loop Until Data(i, j) = ""
  Next i
  With Sheets("Sheet3")
    .UsedRange.ClearContents
    .Range("A1").Resize(k, 2).Value = Results
  End With
End Sub

 

[ptaylor123]

Thank you so much, it worked brilliantly!!!!!!!!!!

 

[Peter_SSs]

Thank you so much, it worked brilliantly!!!!!!!!!!

Glad you had a successful outcome

 

[ptaylor123]

Thanks so much for the help!

Just out of interest, if i wanted to put the data back to how it was, are you able to tell me the macro for this?

I.e Data is now


A 1
A 2
A 3
B 4
C 5
C 6
C 7
C 8
D 9
D 1
E 2
E 3
E 4

And i need it to be


A 1 2 3
B 4
C 5 6 7 8
D 9 1
E 2 3 4

Thanks again for all of your help!!

Phil

 

[Peter_SSs]

Assuming the two-columns table is columns A:B on the active sheet and the results are to replace whatever is on Sheet1, try this

Sub UnMakeTable()
  Dim Data, Results
  Dim i As Long, j As Long, k As Long, ubData1 As Long, Maxj As Long
  Dim bNew As Boolean
  
  ubData1 = Range("A" & Rows.Count).End(xlUp).Row
  Data = Range("A1:B" & ubData1 + 1).Value
  ReDim Results(1 To ubData1, 1 To ubData1 + 1)
  bNew = True
  Maxj = 2
  For i = 1 To ubData1
    If bNew Then
      k = k + 1
      j = 2
      Results(k, 1) = Data(i, 1)
      Results(k, 2) = Data(i, 2)
    Else
      j = j + 1
      Results(k, j) = Data(i, 2)
      If j > Maxj Then Maxj = j
    End If
    bNew = Data(i, 1) <> Data(i + 1, 1)
  Next i
  With Sheets("Sheet1")
    .UsedRange.ClearContents
    .Range("A1").Resize(k, Maxj).Value = Results
  End With
End Sub