none
How to copy same range from multiple worksheets and paste into a new worksheet with Separate columns RRS feed

  • Question

  • I have maybe 60-70 sheets in one excel file. I want to copy a specific range (say A1:A100) from all the the sheets and paste them into a separate workbook with different columns. So if I have 60 sheets, I'll have 60 columns in the new workbook. I would like to do this in VBA code. I have something that does some of this 

    Dim lRow As Long
    Dim sh As Worksheet
    Dim shArc As Worksheet
    Dim cnt As Integer: cnt = 1
    Set shArc = ThisWorkbook.Worksheets("Archive")
    For Each sh In ThisWorkbook.Worksheets
        If (sh.Name <> "Archive") Then
            If (cnt = 1) Then
                lRow = shArc.Range("A1048576").End(xlUp).Row
            Else
                lRow = shArc.Range("A1048576").End(xlUp).Row + 1
            End If
            sh.Range("A1:A100").Copy _
            Destination:=shArc.Cells(lRow, 1)
            cnt = cnt + 1
        End If
    Next
    Set shArc = Nothing
    Set sh = Nothing

    But the problem with this is that it is all pasted into one column. Anyone know how to get into separate columns?

    Wednesday, July 26, 2017 3:38 AM

Answers

  • Like this:

        Dim lCol As Long
        Dim sh As Worksheet
        Dim shArc As Worksheet
        Set shArc = ThisWorkbook.Worksheets("Archive")
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> "Archive" Then
                lCol = lCol + 1
                sh.Range("A1:A100").Copy Destination:=shArc.Cells(1, lCol)
            End If
        Next sh
        Set shArc = Nothing
        Set sh = Nothing


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Svylol Thursday, August 3, 2017 5:51 PM
    Wednesday, July 26, 2017 4:19 AM
  • Hi Svylol,

    You could also copy the data to a new workbook or another exist workbook.

    Here is the example.

    Sub Test()

        Dim sh As Worksheet

        Dim shArc As Worksheet

        Set shArc = Application.Workbooks.Add.Worksheets(1)

        'Set shArc = Application.Workbooks.Open("filename").Worksheets(1)

        For i = 1 To ThisWorkbook.Worksheets.Count

                Set sh = ThisWorkbook.Worksheets(i)

                sh.Range("A1:A100").Copy Destination:=shArc.Cells(1, i)

        Next i

    End Sub

    Best Regards,

    Terry

    • Proposed as answer by Terry Xu - MSFT Thursday, August 3, 2017 8:23 AM
    • Marked as answer by Svylol Thursday, August 3, 2017 5:51 PM
    Thursday, July 27, 2017 7:33 AM

All replies

  • Like this:

        Dim lCol As Long
        Dim sh As Worksheet
        Dim shArc As Worksheet
        Set shArc = ThisWorkbook.Worksheets("Archive")
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> "Archive" Then
                lCol = lCol + 1
                sh.Range("A1:A100").Copy Destination:=shArc.Cells(1, lCol)
            End If
        Next sh
        Set shArc = Nothing
        Set sh = Nothing


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Svylol Thursday, August 3, 2017 5:51 PM
    Wednesday, July 26, 2017 4:19 AM
  • Hi Svylol,

    You could also copy the data to a new workbook or another exist workbook.

    Here is the example.

    Sub Test()

        Dim sh As Worksheet

        Dim shArc As Worksheet

        Set shArc = Application.Workbooks.Add.Worksheets(1)

        'Set shArc = Application.Workbooks.Open("filename").Worksheets(1)

        For i = 1 To ThisWorkbook.Worksheets.Count

                Set sh = ThisWorkbook.Worksheets(i)

                sh.Range("A1:A100").Copy Destination:=shArc.Cells(1, i)

        Next i

    End Sub

    Best Regards,

    Terry

    • Proposed as answer by Terry Xu - MSFT Thursday, August 3, 2017 8:23 AM
    • Marked as answer by Svylol Thursday, August 3, 2017 5:51 PM
    Thursday, July 27, 2017 7:33 AM
  • Hi Svylol,

    Has your original issue been resolved? If it has, I would suggest you mark the helpful reply or provide your solution and then mark it as answer to close this thread. 
    If not, please feel free to let us know your current issue.

    Best Regards,

    Terry

    Thursday, August 3, 2017 8:23 AM