Results 1 to 4 of 4

Thread: Converge Data From Multiple Columns To Single Column

  1. #1
    Member ayazgreat's Avatar
    Join Date
    Mar 2012
    Posts
    86
    Rep Power
    13

    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.
    Attached Files Attached Files
    Somthing is better than nothing

  2. #2
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    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
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #3
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    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

  4. #4
    Member ayazgreat's Avatar
    Join Date
    Mar 2012
    Posts
    86
    Rep Power
    13
    Thank you very much both of you, it works fine



    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 06-11-2023 at 01:12 PM.
    Somthing is better than nothing

Similar Threads

  1. Replies: 3
    Last Post: 05-23-2013, 11:17 PM
  2. Replies: 1
    Last Post: 05-09-2013, 08:56 AM
  3. Replies: 2
    Last Post: 03-21-2013, 10:38 PM
  4. Replies: 14
    Last Post: 01-26-2013, 04:58 AM
  5. Replies: 2
    Last Post: 06-14-2012, 04:10 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •