Copying and Merging Last Columns from Multiple Worksheets

Question

I have about 30 worksheets with 20+ columns each and a large number of rows. How might one go about telling Excel to select the last column that contains text in the second row from each worksheet and place them in a new worksheet? The following code seems close:

Sub CopyRange()
    Dim bottomD As Integer
    Dim ws As Worksheet
    For Each ws In Sheets(Array("A", "B", "C", "D"))
        ws.Activate
        bottomD = Range("D" & Rows.Count).End(xlUp).Row
        Range("A2:D" & bottomD).Copy Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Next ws
End Sub

Instead of bottomD = Range("D" & Rows.Count).End(xlUp).Row I should be able to use something like furthest = Range(Columns.Count & "2").End(xlRight).Column. I have a couple of questions:

1) Does my first change make sense?

2) Is there a way to have the macro look through a loop instead of Sheets(Array("A", "B", "C", "D"))? In my case the sheets all have similar names so it would be possible to simply enumerate Array("Name" & i) for worksheet number i.

Tony Dallimore Tony Dallimore · Accepted Answer · 2014-06-27T19:51:48

It is possible to access worksheets in a loop using an index into the Worksheets collection. See code below.

Use data type Long not Integer unless you are using a 16-bit computer. Integer specifies a 16-bit number which on a 32-bit computer requires special processing. Also with Excel 2007 and later, an Integer is not big enough to hold larger row numbers.

Avoid activating worksheets because it is a slow command. If it is essential to activate Worksheets, include

Application.ScreenUpdating = False

which will reduce screen flash as the screen is repainted each time you switch worksheets,

furthest = Range(Columns.Count & "2").End(xlRight).Column is the correct idea but the implementation is faulty. Columns.Count returns the number of columns for your version of Excel. For Excel 2003, there are 256 columns. Later versions have 16384 columns. So you are specifying Range(2562) or Range(163842). See code below for correct syntax.

I do not understand Range("A2:D" & bottomD).Copy Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) You say you want to copy a column but Range("A2:D" & bottomD) is not a column. You are then placing all the source columns in column A of worksheet “Summary”. Is this really what you wanted? In the code below, I have placed the source columns across the sheet headed by the worksheet name which I would have thought was a more useful arrangement. If this is not what you want, I can adjust the code to give the result you do want.

Option Explicit
Sub MergeColumns()

  Dim ColSrcCrnt As Long
  Dim ColSumCrnt As Long
  Dim InxWsht As Long
  Dim RowSrcLast As Long
  Dim WshtSum As Worksheet

  Set WshtSum = Worksheets("Summary")

  ' Clear existing contents
  WshtSum.Cells.EntireRow.Delete
  ColSumCrnt = 1

  For InxWsht = 1 To Worksheets.Count

    With Worksheets(InxWsht)
      If .Name <> "Summary" Then

        ' Write worksheet name to row 1 of current column of "Summary"
        WshtSum.Cells(1, ColSumCrnt).Value = .Name

        ' This worksheet is not the summary so find the last
        ' column with a value in row 2.
        ColSrcCrnt = .Cells(2, Columns.Count).End(xlToLeft).Column

        If .Cells(Rows.Count, ColSrcCrnt).Value <> "" Then
          ' Bottom cell of column used.  It will be lost.  Colour
          ' worksheet name to report error.
          WshtSum.Cells(1, ColSumCrnt).Font.Color = RGB(255, 0, 0)
          RowSrcLast = Rows.Count - 1
        Else
          ' There is room for entire column in Summary
          RowSrcLast = .Cells(Rows.Count, ColSrcCrnt).End(xlUp).Row
        End If

        ' Copy column
        .Range(.Cells(1, ColSrcCrnt), _
               .Cells(RowSrcLast, ColSrcCrnt)).Copy Destination:=WshtSum.Cells(2, ColSumCrnt)

        ColSumCrnt = ColSumCrnt + 1     ' Step ready for next worksheet

      End If

    End With

  Next

End Sub

Copying and Merging Last Columns from Multiple Worksheets

1 Answers