Converge Data From Multiple Columns To Single Column

hi

I want to copy data (from col a to onwards) from sheet1 to sheet2 (converting in only 3 cols) ignoring cells having blank or 0 value. I am attachig here an example workbook.

Thanks in advance.

Hi

try

Code:

---

Sub kTest()
   
    Dim k, ka(), i As Long, c As Long, n As Long
   
    With Sheet1
        .UsedRange.Replace "0", vbNullString, 1
        k = .Range("a1").CurrentRegion.Value2
    End With
   
    ReDim ka(1 To UBound(k, 1) * UBound(k, 2), 1 To 3)
   
    For c = 3 To UBound(k, 2)
        For i = 2 To UBound(k, 1)
            If Len(k(i, c)) Then
                n = n + 1
                ka(n, 1) = k(i, 1)
                ka(n, 2) = k(i, c)
                ka(n, 3) = k(i, 2)
            End If
        Next
    Next
    If n Then
        Sheet2.Range("e2").Resize(n, UBound(ka, 2)) = ka
        Sheet2.Range("e1").Resize(, UBound(ka, 2)) = [{"Loc","Total","Reg"}]
    End If
End Sub

---

Another macro for you to consider...

Code:

---

Sub RearrangeData()
  Dim Col As Long, LastRow As Long, OutRow As Long, RowCount As Long
  Dim WSdata As Worksheet, WSout As Worksheet
  Const StartRow As Long = 2
  Set WSdata = Worksheets("Sheet1")
  Set WSout = Worksheets("Sheet2")
  LastRow = WSdata.Cells(Rows.Count, "A").End(xlUp).Row
  RowCount = LastRow - StartRow + 1
  WSout.Range("A1:C1") = Array("Loc", "Total", "Reg")
  OutRow = 2
  For Col = 3 To 6  'Columns C thru F
    WSout.Cells(OutRow, "A").Resize(RowCount) = WSdata.Cells(StartRow, "A").Resize(RowCount).Value
    WSout.Cells(OutRow, "B").Resize(RowCount) = WSdata.Cells(StartRow, Col).Resize(RowCount).Value
    WSout.Cells(OutRow, "C").Resize(RowCount) = WSdata.Cells(StartRow, "B").Resize(RowCount).Value
    OutRow = OutRow + RowCount
  Next
  WSout.Columns("B").Replace 0, "", xlWhole
  On Error GoTo NoBlanks
  WSout.Columns("B").SpecialCells(xlBlanks).EntireRow.Delete
NoBlanks:
End Sub

---

Thank you very much both of you, it works fine



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA