Convert Multiple Rows into Single Column in Excel [closed] - excel

Question

Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 4 years ago.
Improve this question
I have this huge data of books of various publishers, some record in 4 lines some in 5 some in 3, each record ends with an empty cell, which looks like this:
1111
2222
3333
4444
emptyCell
5555
6666
7777
8888
9999
emptyCell
1234
5678
9999
What formula/macro code can be used to get the output of:
1111 2222 3333 4444
5555 6666 7777 8888 9999
1234 5678 9999

Answer 1

one of the possible solutions:
Sub test()
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim rng As Range: Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp).Offset(1))
Dim cl As Range, key As Variant, strToAdd$: strToAdd = ""
For Each cl In rng
If cl.Value2 <> "" Then
strToAdd = strToAdd & " " & cl.Value2
Else
dic.Add strToAdd, Nothing
strToAdd = ""
End If
Next cl
Dim sh As Worksheet, i&: i = 1
Set sh = Worksheets.Add: sh.Name = "Result"
For Each x In dic
sh.Cells(i, "A").Value2 = x
i = i + 1
Next x
End Sub
test based on provided dataset:
UPDATE: in case when the results in a row should have their own cell
Sub test2()
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim rng As Range: Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp).Offset(1))
Dim cl As Range, key As Variant, strToAdd$: strToAdd = ""
For Each cl In rng
If cl.Value2 <> "" Then
strToAdd = strToAdd & "|" & cl.Value2
Else
dic.Add strToAdd, Nothing
strToAdd = ""
End If
Next cl
Dim sh As Worksheet: Set sh = Worksheets.Add:
Dim x, y$, z&, i&: i = 1
sh.Name = "Result " & Replace(Now, ":", "-")
For Each x In dic
y = Mid(x, 2, Len(x))
For z = 0 To UBound(Split(y, "|"))
sh.Cells(i, z + 1).Value2 = Split(y, "|")(z)
Next z
i = i + 1
Next x
End Sub
test based on provided dataset:

Answer 2

Use the following VBA code to transpose data with spaces. This will not remove the original code.
Sub Transpose()
Dim rng As Range
Dim i As Long
Dim j As Long
Set rng = Cells(Rows.Count, 1).End(xlUp)
j = 1
For i = 1 To rng.Row Step 5
Cells(j, "B").Resize(1, 5).Value = _
Application.Transpose(Cells(i, "A").Resize(6, 1))
j = j + 1
Next
End Sub
source

Answer 3

Public Sub DataTranspose()
Dim NoRows As Long, CurrentRow As Long, OffsetColumn As Long
Dim ResetCurrentRow As Long, ResetOffsetColumn As Long
Dim i As Long
' Replace with your destination. This will start writing back to Row 1 Column B
ResetCurrentRow = 1
ResetOffsetColumn = 2
' Replace with reference to your sheet
With ActiveSheet
NoRows = .Cells(.Rows.Count, 1).End(xlUp).Row
CurrentRow = ResetCurrentRow
OffsetColumn = ResetOffsetColumn
For i = 1 To NoRows
If .Cells(i, 1) <> vbNullString Then
.Cells(CurrentRow, OffsetColumn).Value2 = .Cells(i, 1).Value2
OffsetColumn = OffsetColumn + 1
Else
CurrentRow = CurrentRow + 1
OffsetColumn = ResetOffsetColumn
End If
Next i
End With
End Sub

Answer 4

I interpreted the question as the cell values should have their own cell when they are copied to the row.
You need to define which workbook name, worksheet names and also which column the result should start and paste into (columnComparePaste = 2 'where 2 = Column B).
This is a possible solution then.
VBA Code
Sub CompareCopyFilter()
Dim CopyFromWorkbook As Workbook
Set CopyFromWorkbook = Workbooks("Book2.xlsm") 'Name the Workbook that should be copied from
Dim CopyToWorkbook As Workbook
Set CopyToWorkbook = Workbooks("Book2.xlsm") 'Name the Workbook that should be copied to
Dim CopyFromSheet As Worksheet
Set CopyFromSheet = CopyFromWorkbook.Worksheets("Sheet1") 'Name the Worksheet that should be copied from
Dim CopyToSheet As Worksheet
Set CopyToSheet = CopyToWorkbook.Worksheets("Sheet1") 'Name the Worksheet that should be copied to
Dim lrow As Long
Dim lrowCompare As Long
Dim lrowPasteCopyTo As Long
Dim Val As String
Dim ValCompare As String
Dim i As Long
Dim j As Long
Dim Test As String
Dim Test2 As String
Dim columnComparePaste As Long
Dim columnCompare As Long
columnComparePaste = 2 'Which column number the data should be past into (Column B = 2)
lrow = CopyFromSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Find last row in sheet that should be copied from
lrowCompare = CopyToSheet.Cells(Rows.Count, "B").End(xlUp).Row 'Find last row in sheet that should be copied from
columnCompare = columnComparePaste 'Dummy variable to reset column number
For i = 1 To lrow 'Find last row in the range you want to copy from
Val = CopyFromSheet.Cells(i, "A").Value 'Get the value from the cell you want to copy from
If Val <> "" Then 'If cell is not empty then
CopyFromSheet.Activate 'Activate worksheet to copy from
CopyFromSheet.Range(Cells(i, "A"), Cells(i, "A")).Copy 'Copy cell from column A, row i
CopyToSheet.Activate 'Activate worksheet to paste into
CopyToSheet.Range(Cells(lrowCompare, columnCompare), Cells(lrowCompare, columnCompare)).PasteSpecial xlPasteValues 'Paste cell from into Column set earlier, add 1 column for each loop
columnCompare = columnCompare + 1 'When value is pasted to column, add 1 column for next loop to paste into
Else
lrowCompare = lrowCompare + 1 'For each empty cell add one row below previous to paste into
columnCompare = columnComparePaste 'Reset the column value where paste should start
End If
Next i
Application.CutCopyMode = False 'Deselect any copy selection
End Sub
Result in Excel: