How can we find multiple used range addresses in one sheet? - excel

How can we loop through all cells in a sheet and find multiple used range addresses on this one sheet? In this screen shot we have used ranges of B2:F17, I2:M17, Q2:U17, C19:M34, and Q19:U34. How can I identify these beginning and ending cell addresses of these five used ranges, and print them in an array of cells? I have some sample code that shows the total used range on a sheet.
Sub Vba_Used_Range()
Dim iCell As Range
Dim iRange As Range
Dim c As Long
Dim i As Long
Set iRange = ActiveSheet.UsedRange
For Each iCell In ActiveSheet.UsedRange
c = c + 1
If IsEmpty(iCell) = True Then
i = i + 1
End If
Next iCell
MsgBox "There are total " & c & _
" cell(s) in the range, and out of those " & _
i & " cell(s) are empty."
End Sub
Again, how can I print cell addresses for multiple used ranges on one sheet?

Empty Cells in Worksheet Regions
Inspired by userMT.
It is assumed that the regions contain values, not formulas.
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the number of cells and the number of empty cells
' of the worksheet regions containing values in a message box.
' Calls: RefWorksheetValueRegions,CountEmptyCells.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Vba_Used_Range()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim uarg As Range: Set uarg = RefWorksheetValueRegions(ws)
If uarg Is Nothing Then Exit Sub
Dim ecCount As Long: ecCount = CountEmptyCells(uarg)
MsgBox "There is a total of " & uarg.Cells.Count & _
" cell(s) in the range, and out of those " & _
ecCount & " cell(s) are empty."
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the worksheet regions containing values.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefWorksheetValueRegions( _
ByVal ws As Worksheet) _
As Range
Const ProcName As String = "RefWorksheetValueRegions"
On Error GoTo ClearError
Dim turg As Range
Dim curg As Range
Dim arg As Range
For Each arg In ws.UsedRange.SpecialCells(xlCellTypeConstants).Areas
' Debug.Print "Area: " & arg.Address
If turg Is Nothing Then
Set curg = arg.CurrentRegion
Set turg = curg
Else
If Intersect(arg, curg) Is Nothing Then
Set curg = arg.CurrentRegion
Set turg = Union(turg, curg)
End If
End If
Next arg
If turg Is Nothing Then Exit Function
' For Each arg In turg.Areas
' Debug.Print "Total Area: " & arg.Address
' Next arg
Set RefWorksheetValueRegions = turg
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the number of empty cells of a range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CountEmptyCells( _
ByVal mrg As Range) _
As Long
Const ProcName As String = "CountEmptyCells"
On Error GoTo ClearError
Dim arg As Range
Dim ecCount As Long
For Each arg In mrg.Areas
On Error Resume Next
ecCount = ecCount + arg.SpecialCells(xlCellTypeBlanks).Count
On Error GoTo ClearError
Next arg
CountEmptyCells = ecCount
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function

Dim rArea As Range
For Each rArea In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants+xlCellTypeFormulas).Areas
Debug.Print rArea.Address
Next rArea

Related

How to copy a range and paste diagonally using vba

Hi If I have a range of data from A1:E1 and I want to copy and paste in the same sheet with incrementing both the column and row (in another word paste them diagonally), anyone can help with this vba?
my current code is this but this code only paste to B2:F2... i want to paste the data until row number 3500.. (with incrementing row and column).. data in A1:E1 is fix, so i would like to paste them to B2:F2, C3:G3, D4:H4 etc..
Sub m1()
Worksheets("Sheet1").Range("A1:E1").Copy
last_row = Worksheets("Sheet1").Range("B" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row + 1
If last_row > 100000 Then last_row = 1
Worksheets("Sheet1").Range("B" & last_row).PasteSpecial
End Sub
There is no build-in function to copy diagonally. You will need to loop over all rows and copy the data individually.
The following piece of code shows you how that could look like
Const MaxRows = 3500
With Worksheets("Sheet1")
Dim r As Range
Set r = .Range("A1:E1")
r.Copy
Dim offset As Long
For offset = 1 To MaxRows
r.offset(offset, offset).PasteSpecial
Next
End With
However, this will be painfully slow. If you just want to copy data, you can change the code to
With Worksheets("Sheet1")
Dim r As Range, data
Set r = .Range("A1:E1")
data = r.Value2
Dim offset As Long
For offset = 1 To MaxRows
r.offset(offset, offset).Value2 = data
Next
End With
Copy Diagonally Using the Range.Copy Method
The Code
Option Explicit
Sub CopyDiagonallyTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
CopyDiagonally wb, "Sheet1", "A1:E1", 3499, 1, 1
' Note that you could omit the last two argument's parameters
' since they are optional and by default equal to 1.
End Sub
Sub CopyDiagonally( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
ByVal SourceRangeAddress As String, _
Optional ByVal NumberOfCopies As Long = 1, _
Optional ByVal RowOffset As Long = 1, _
Optional ByVal ColumnOffset As Long = 1)
Const ProcName As String = "CopyDiagonally"
Dim dt As Double: dt = Timer ' measure duration
Dim n As Long
Dim LastAddress As String
Dim AnErrorOccurred
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim srg As Range: Set srg = ws.Range(SourceRangeAddress)
Dim drg As Range: Set drg = srg
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For n = 1 To NumberOfCopies
Set drg = drg.Offset(RowOffset, ColumnOffset)
LastAddress = drg.Address(0, 0) ' keep track in case of an error
srg.Copy drg
Next n
ProcExit:
On Error Resume Next
If Not Application.ScreenUpdating Then
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
dt = Timer - dt
Dim tString As String: tString = Format(dt, "0.###") & " seconds"
Dim MsgString As String
MsgString = "Diagonally Copying Stats" & vbLf & vbLf _
& "Source Range Address: '" & SourceRangeAddress & "'" & vbLf _
& "Number of Copies Created: " & n - 1 & " (" _
& NumberOfCopies & ")" & vbLf _
& "Last Range Address: '" & LastAddress & "'" & vbLf _
& "Operation Duration: " & tString
MsgBox MsgString, _
IIf(AnErrorOccurred, vbCritical, vbInformation), ProcName
Debug.Print MsgString
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
AnErrorOccurred = True
Resume ProcExit
End Sub
Results in the Immediate Window
Results for CopyDiagonally wb, "Sheet1", "A1:E1", 3499, 1, 1 (Requested)
Diagonally Copying Stats
Source Range Address: 'A1:E1'
Number of Copies Created: 3499 (3499)
Last Range Address: 'EDP3500:EDT3500'
Operation Duration: 34.305 seconds
Results for CopyDiagonally wb, "Sheet1", "A1:E1", 3499, 1, 500
(an error occurs since there are only 16384 columns)
'CopyDiagonally' Run-time error '1004':
Application-defined or object-defined error
Diagonally Copying Stats
Source Range Address: 'A1:E1'
Number of Copies Created: 163 (3499)
Last Range Address: 'XBY164:XCC164'
Operation Duration: 1.375 seconds

Select range starting at A2

I found the following code to take the data on the TrialBalance worksheet and convert it into a table. It creates the table and renames it, but the range needs to start at A2 where my table heading are stored.
Sub ConvertTrialBalanceToTable()
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook 'Trial Balance Template File
wb1.Sheets("TrialBalance").Range("A2").CurrentRegion.Select
If ActiveSheet.ListObjects.Count < 1 Then
ActiveSheet.ListObjects.Add.Name = ActiveSheet.Name
End If
End Sub
Convert 'CurrentRegion' to Excel Table When Occupied Rows Above or Columns to the Left of First Cell
If the code is in the TrialBalance template file, use ThisWorkbook instead of ActiveWorkbook.
Sub ConvertTrialBalanceToTable()
With ActiveWorkbook.Worksheets("TrialBalance")
If .ListObjects.Count = 0 Then
.ListObjects.Add(xlSrcRange, _
RefCurrentRegion(.Range("A2")), , xlYes).Name = .Name
End If
End With
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function

Excel VBA Match Split Search String

Is there a way to split a search by each word and compare partial matches in Excel?
For example,
If my table contains:
example test phrase | result1
phrase test two | result2
excluded phrase | result3
If I search with: (Using A1 as the search field)
searchString = "*test phrase*"
searchItem = Application.Match(searchString, Worksheets("Table").Range("A2:A100"), 0)
This returns only result 1, but not result 2 as it is looking for the entire phrase, only in the order it was typed.
With the search string "test phrase" entered, I need result1 AND result2 to return, without including result3. (In this example)
Does Excel/VBA have any built in way to do this?
If you have windows Excel O365, you can do this with a formula:
D6: =FILTER($B$2:$B$100,IFERROR(SEARCH(FILTERXML("<t><s>"&SUBSTITUTE(A1," ","</s><s>")&"</s></t>","//s"),$A$2:$A$100),FALSE))
Note: If you want to return the contents of the matching cell, rather than what wrote in your question, merely change B2:B100 --> A2:A100
Sub Strings of a String in Another String
Upside Down
For the task you mentioned in the comments, you will probably only need the last, the 3rd procedure, the function.
The 2nd procedure is a practical example of how to use the function.
The 1st procedure is a practical example of how to use the 2nd procedure.
The Code
Option Explicit
' How to use 'getMatchingValues'.
Sub testGetMatchingValues()
' Initialize error handling.
Const ProcName As String = "testGetMatchingValues"
On Error GoTo clearError ' Turn on error trapping.
' Source
Const wsName As String = "Sheet1"
Const rngAddress As String = "A2:A100"
' Target
Const tgtName As String = "Sheet2"
Const tgtFirstCell As String = "A2"
' Other
Const SearchString = "test phrase"
Dim wb As Workbook: Set wb = ThisWorkbook ' The workbook with this code.
' Define Source Range.
Dim rng As Range
Set rng = wb.Worksheets(wsName).Range(rngAddress)
' Write values that contain all sub strings of Search String to Data Array.
Dim Data As Variant
getMatchingValues Data, rng, SearchString
If IsEmpty(Data) Then
GoTo ProcExit
End If
' Write values from Data Array to Target Range.
Set rng = wb.Worksheets(tgtName).Range(tgtFirstCell)
.Resize (UBound(Data) - LBound(Data) + 1)
rng.Value = Application.Transpose(Data)
' Inform user.
MsgBox "Done.", vbInformation, "Success"
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' In each cell of a column range ('ColumnRange'), searches for each sub string
' of a specified string ('SearchString').
' If all sub strings are found, writes the value of the cell
' to a 1D array ('Result1D').
' The search is by default case-sensitive i.e. 'A<>a' (ignoreCase = False).
' It uses the 'foundAllStrings' function.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub getMatchingValues(ByRef Result1D As Variant, _
ColumnRange As Range, _
ByVal SearchString As String, _
Optional ByVal ignoreCase = False)
' Initialize error handling.
Const ProcName As String = "getMatchingValues"
On Error GoTo clearError ' Turn on error trapping.
' Reset Result Array.
Result1D = Empty
' Validate Column Range.
If ColumnRange Is Nothing Then
GoTo ProcExit
End If
' Write values from first column of Column Range to Source Array.
Dim rng As Range: Set rng = ColumnRange.Columns(1)
Dim Source As Variant
If rng.Rows.Count > 1 Then
Source = rng.Value
Else
ReDim Source(1 To 1, 1 To 1)
Source(1, 1) = rng.Value
End If
' Write values from Source Array to Result Array.
ReDim Result1D(0 To UBound(Source) - 1)
Dim k As Long: k = LBound(Result1D) - 1
Dim i As Long
For i = 1 To UBound(Source)
If foundAllStrings(SearchString, Source(i, 1), ignoreCase) Then
k = k + 1
Result1D(k) = Source(i, 1)
End If
Next i
' Resize Result Array.
If k >= LBound(Result1D) Then
ReDim Preserve Result1D(LBound(Result1D) To k)
Else
Result1D = Empty
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' In a specified string ('SuperString'), searches for each sub string
' of another specified string ('SearchString').
' If all sub strings are found, it returns 'True', otherwise 'False'.
' The search is by default case-sensitive i.e. 'A<>a' (ignoreCase = False).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function foundAllStrings(SearchString As String, _
ByVal SuperString As String, _
Optional ByVal ignoreCase = False) As Boolean
' Initialize error handling.
Const ProcName As String = "foundAllStrings"
On Error GoTo clearError ' Turn on error trapping.
' Determine case sensitivity.
Dim iCase As Long
If ignoreCase Then
iCase = 1 ' vbTextCompare
End If
' Write sub strings of Search String to Sub Strings Array.
Dim SubStrings As Variant
SubStrings = Split(SearchString) ' " " by default
' Check each sub string if it is contained in Super String.
Dim j As Long
For j = LBound(SubStrings) To UBound(SubStrings)
If InStr(1, SuperString, SubStrings(j), iCase) = 0 Then
GoTo ProcExit
End If
Next j
' All sub strings were found in Super String.
foundAllStrings = True
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function

List empty cell numbers in a MsgBox

I have code to check empty cells in a range. I need those empty cell numbers to appear in a MsgBox.
Sub IsEmptyRange()
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For Each cell In Range("B1:B19")
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in your range"
'I NEED THE EMPTY CELLS TO APPEAR IN THE ABOVE MSGBOX
End If
End Sub
Just use:
msgbox Range("B1:B19").SpecialCells(xlCellTypeBlanks).Address
This solution adapts your code.
Dim cell As Range
Dim emptyStr As String
emptyStr = ""
For Each cell In Range("B1:B19")
If IsEmpty(cell) Then _
emptyStr = emptyStr & cell.Address(0, 0) & ", "
Next cell
If emptyStr <> "" Then MsgBox Left(emptyStr, Len(emptyStr) - 2)
If the cell is empty, it stores the address in emptyStr. The if condition can be condensed as isEmpty returns a Boolean.
Please try this code.
Sub ListEmptyCells()
Dim Rng As Range
Dim List As Variant
Dim Txt As String
Set Rng = Range("B1:B19")
On Error Resume Next
List = Rng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
If Err Then
Txt = "There are no empty cells in" & vbCr & _
"the examined range."
Else
Txt = "The following cells are empty." & vbCr & _
Join(Split(List, ","), vbCr)
End If
MsgBox Txt, vbInformation, "Range " & Rng.Address(0, 0)
Err.Clear
End Sub
It uses Excel's own SpecialCells(xlCellTypeBlank), avoiding an error which must occur if this method returns nothing, and presenting the result in a legible format created by manipulating the range address if one is returned.
List blanks via dynamic arrays and spill range reference
Using the new dynamic array possibilities of Microsoft 365 (writing e.g. to target C1:C? in section b))
=$B$1:$B$19=""
and a so called â–ºspill range reference (as argument in the function Textjoin(), vers. 2019+ in section c))
C1# ' note the `#` suffix!
you could code as follows:
Sub TestSpillRange()
With Sheet1
'a) define range
Dim rng As Range
Set rng = .Range("B1:B19")
'b) check empty cell condition and enter boolean values into spill range C1#
.Range("C1").Formula2 = "=" & rng.Address & "="""""
'c) choose wanted values in spill range and connect them to result string
Dim msg As Variant
msg = Evaluate("TextJoin("","",true,if(C1#=true,""B""&row(C1#),""""))")
MsgBox msg, vbInformation, "Empty cells"
End With
End Sub
Find Blank Cells Using 'SpecialCells'
The 2nd Sub (listBlanks) is the main Sub.
The 1st Sub shows how to use the main Sub.
The 3rd Sub shows how SpecialCells works, which on one hand might be considered
unreliable or on the other hand could be used to one's advantage.
After using the 3rd Sub, one could conclude that SpecialCells 'considers' only cells at the intersection of the UsedRange and the 'supplied' range.
The Code
Option Explicit
Sub testListBlanks()
Const RangeAddress As String = "B1:B19"
Dim rng As Range: Set rng = Range(RangeAddress)
listBlanks rng
listBlanks rng, True
End Sub
Sub listBlanks(SourceRange As Range, _
Optional useList As Boolean = False)
Const proc As String = "'listBlanks'"
On Error GoTo clearError
Dim rng As Range: Set rng = SourceRange.SpecialCells(xlCellTypeBlanks)
Dim msgString As String
GoSub writeMsg
MsgBox msgString, vbInformation, "Blank Cells Found ('" & proc & "')"
Exit Sub
writeMsg:
msgString = "Blank Cells in Range '" & SourceRange.Address(False, False) _
& "'" & vbLf & vbLf & "The cells in range '" _
& rng.Address(False, False) & "' are blank."
If useList Then GoSub writeList
Return
writeList:
Dim cel As Range, i As Long, CellList As String
For Each cel In rng.Cells
CellList = CellList & vbLf & cel.Address(False, False)
Next cel
msgString = msgString & vbLf & vbLf _
& "The range contains the following " & rng.Cells.Count _
& " empty cells:" & vbLf & CellList
Return
clearError:
If Err.Number = 1004 And Err.Description = "No cells were found." Then
MsgBox "No blank cells in range '" & SourceRange.Address(False, False) _
& "' were found.", vbInformation, "No Blanks ('" & proc & "')"
Exit Sub
Else
MsgBox "An unexpected error occurred." & vbLf _
& "Run-time error '" & Err.Number & "': " & Err.Description, _
vbCritical, "Error in " & proc
End If
End Sub
Sub testUsedRangeAndSpecialCells()
Const wsName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
With ws
.Range("A:B").ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(1, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(2, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 3).Value = 3
Debug.Print .UsedRange.Address
.Cells(2, 3).ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 2).ClearContents
Debug.Print .Columns("B").SpecialCells(xlCellTypeBlanks).Address
Dim rng As Range: Set rng = .Columns("C")
Debug.Print rng.Address
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number <> 0 Then
MsgBox "We know that all cells are blank in range '" _
& rng.Address(False, False) & "', but 'SpecialCells' " _
& "doesn't consider them since they are not part of 'UsedRange'."
Debug.Print "No blank cells (not quite)"
Else
Debug.Print rng.Address
End If
On Error Goto 0
.Cells(3, 4).Value = 4
Set rng = rng.SpecialCells(xlCellTypeBlanks)
Debug.Print rng.Address(False, False)
End With
End Sub
The result of the 3rd Sub (testUsedRangeAndSpecialCells)
$A$1
$A$1
$A$1:$B$1
$A$1:$B$2
$A$1:$B$2
$A$1:$C$2
$A$1:$B$2
$B$1
$C:$C
No blank cells (not quite)
C1:C3

Copy same column from multiple worksheets to new worksheet

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!
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
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

Resources