Copy same column from multiple worksheets to new worksheet - excel

Question

I have a workbook with about 20 sheets that has about 130 rows. What I'd like to do is copy column B from each worksheet and paste into either a new worksheet or a new workbook. Either is fine, I've tried both ways and I can seem to get the column B data from each worksheet to be in separate columns.
I have tried the following code and it seems to loop through the sheets but it only retains column B from the last sheet.
Is there a way to modify this code to paste each column B from each worksheet in a new column in the new sheet? I've tried other code snippets from posts here and none seem to do the final task.
Sub CopyColumns()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long
Application.ScreenUpdating = False
For Each Source In ThisWorkbook.Worksheets
If Source.Name = "Master" Then
MsgBox "Master sheet already exist"
Exit Sub
End If
Next
Set Destination = Worksheets.Add(after:=Worksheets("summary"))
Destination.Name = "Master"
For Each Source In ThisWorkbook.Worksheets
If Source.Name <> "Master" And Source.Name <> "summary" Then
Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column
If Last = 1 Then
Source.Range("B4:B129").Copy Destination.Columns(Last)
Else
Source.Range("B4:B129").Copy Destination.Columns(Last + 1)
End If
End If
Next Source
I have also tried the following to no avail
For Each ws In ActiveWorkbook.Worksheets
Set oldcol = ws.Range("B5:B129")
Set newcol = Workbooks("OctTotals.xlsm").Worksheets(1).Columns("B")
oldcol.Copy Destination:=newcol
oldcol.PasteSpecial xlPasteValues
WorksheetFunction.Transpose (newcol.Value)
Next ws
Any assistance would be appreciated!

Answer 1

Untested:
Sub CopyColumns()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim rngDest As Range
Application.ScreenUpdating = False
For Each Source In ThisWorkbook.Worksheets
If Source.Name = "Master" Then
MsgBox "Master sheet already exist"
Exit Sub
End If
Next
Set Destination = Worksheets.Add(after:=Worksheets("summary"))
Destination.Name = "Master"
Set rngDest = Destination.Range("A1") '<< for example: first paste location
For Each Source In ThisWorkbook.Worksheets
If Source.Name <> "Master" And Source.Name <> "summary" Then
Source.Range("B4:B129").Copy rngDest
Set rngDest = rngDest.Offset(0, 1) '<< next column over
End If
Next Source
End Sub

Answer 2

Same Column From Multiple Worksheets to New Worksheet
Copy the complete code into a standard module (e.g. Module1).
Carefully adjust the values in the constants section of the Sub.
Only run the Sub. The Function is called by the Sub.
If you need to place the Target Worksheet before another worksheet,
change wb.Worksheets.Add , wb.Worksheets(AfterSheetNameOrIndex) to
wb.Worksheets.Add wb.Worksheets(AfterSheetNameOrIndex).
The Code
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Copies values of a specified column of each (with possible '
' exceptions) worksheet in a workbook to a newly created '
' worksheet in the same workbook. '
' Remarks: If the worksheet to be created already exists, it will be '
' deleted. Then the result will be calculated and only now '
' the worksheet will be newly created to "recieve the data". '
' The Exceptions Array can be empty (""), or can contain one '
' worksheet name or a comma-separated list of worksheet names. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub copyColumns()
On Error GoTo cleanError
Const Proc As String = "CopyColumns"
Const srcFirstRow As Long = 4
Const srcCol As Variant = 2
Const tgtName As String = "Master"
Const tgtFirstCell As String = "A1"
Const AfterSheetNameOrIndex As Variant = "Summary"
Dim Exceptions As Variant
Exceptions = Array("Summary")
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Delete possibly existing Target Worksheet.
On Error Resume Next
Application.DisplayAlerts = False
wb.Worksheets(tgtName).Delete
Application.DisplayAlerts = True
On Error GoTo cleanError
' Write values from each Source Worksheet to Sources Array of Arrays.
Dim Sources As Variant: ReDim Sources(1 To wb.Worksheets.Count)
Dim ws As Worksheet, r As Long, c As Long
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
c = c + 1
Sources(c) = getColumnValues(ws, srcCol, srcFirstRow)
If Not IsEmpty(Sources(c)) Then
If UBound(Sources(c)) > r Then r = UBound(Sources(c))
Debug.Print r, c, UBound(Sources(c)), "Not Empty"
Else
Debug.Print r, c, "Empty"
End If
End If
Next ws
ReDim Preserve Sources(1 To c)
' Write values from Source Array of Arrays to Target Array.
Dim Target As Variant: ReDim Target(1 To r, 1 To c)
Dim j As Long, i As Long
For j = 1 To c
If Not IsEmpty(Sources(j)) Then
For i = 1 To UBound(Sources(j))
Target(i, j) = Sources(j)(i, 1)
Next i
End If
Next j
' Write values from Target Array to Target Worksheet.
wb.Worksheets.Add , wb.Worksheets(AfterSheetNameOrIndex)
Set ws = wb.ActiveSheet
ws.Name = tgtName
ws.Range(tgtFirstCell).Resize(r, c) = Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description, _
vbCritical, Proc & " Error"
On Error GoTo 0
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values of a non-empty one-column range starting '
' from a specified row, to a 2D one-based one-column array. '
' Returns: A 2D one-based one-column array. '
' Remarks: If the column is empty or its last non-empty row is above '
' the specified row or if an error occurs the function will '
' return an empty variant. Therefore the function's result '
' can be tested with "IsEmpty". '
' If showMessages is set to true, a message box will be '
' displayed; so use it with caution. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnValues(Sheet As Worksheet, _
Optional ByVal AnyColumn As Variant = 1, _
Optional ByVal FirstRow As Long = 1, _
Optional ByVal showMessages As Boolean = False) _
As Variant
' Prepare.
Const Proc As String = "getColumnValues"
If showMessages Then
Dim msg As String
End If
On Error GoTo cleanError
' Define Column Range.
Dim rng As Range
Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then GoTo EmptyColumnIssue
If rng.Row < FirstRow Then GoTo FirstRowIssue
Set rng = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
' Write values from Column Range to Column Array.
Dim Result As Variant
If rng.Rows.Count = 1 Then
ReDim Result(1 To 1, 1 To 1): Result(1, 1) = rng.Value
Else
Result = rng.Value
End If
getColumnValues = Result
' Possibly inform user.
GoSub writeSuccess
Exit Function
writeSuccess:
If showMessages Then
If UBound(Result) > 1 Then msg = "s"
msg = "Range '" & rng.Address(0, 0) & "' " _
& "was successfully written to the 2D one-based " _
& "one-column array containing '" & UBound(Result) & "' " _
& "element" & msg & " (row" & msg & ")."
GoSub msgWSB
MsgBox msg, vbInformation, Proc & ": Success"
End If
Return
EmptyColumnIssue:
If showMessages Then
msg = "Column '" & AnyColumn & "' is empty."
GoSub msgWSB
MsgBox msg, vbExclamation, Proc & ": Empty Column Issue"
End If
Exit Function
FirstRowIssue:
If showMessages Then
msg = "The last non-empty row '" & rng.Row & "' " _
& "is smaller than the specified first row '" & FirstRow & "'."
GoSub msgWSB
MsgBox msg, vbExclamation, Proc & ": First Row Issue"
End If
Exit Function
msgWSB:
msg = msg & vbCr & vbCr & "Worksheet: '" & Sheet.Name & "'" & vbCr _
& "Workbook : '" & Sheet.Parent.Name & "'"
Return
cleanError:
If showMessages Then
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End If
On Error GoTo 0
End Function