So I have a workbook with multiple sheets. All contain the same columns but just different categorical data. I want to grab all the data from those sheets and display/populate to a master sheet in the workbook.
I have tried different methods, but none of them are dynamic. The amount of data can be changed (+/-, either more rows or less rows) in each sheet. Each method I have found seems to be a static solution.
One example is to use the Consolidate option under the data tab, and add the respective reference/range for each sheet you would like to add (not dynamic).
Another option I found was a VBA macro, which populates the headers over and over, which I do not want to happen either, I want them all under the same header (Since the columns are already the same)
Sub Combine()
'UpdatebyExtendoffice20180205
Dim I As Long
Dim xRg As Range
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
Is this achievable?
Sheet 1
Sheet 2
Master Sheet Should Be:
But actually returns the following:
Will this constantly run each time the workbook is closed/opened/updated if it is a macro enabled workbook?
Consolidate All Worksheets
It is assumed that the Combined worksheet already exists with at least the headers which will stay intact.
To make it more efficient, only values are copied (no formats or formulas).
It will utilize the Worksheet Activate event: each time you activate (select) the combined worksheet, the data will automatically be updated.
Sheet Module of the Combined worksheet e.g. Sheet10(Combined)
Option Explicit
Private Sub Worksheet_Activate()
CombineToMaster
End Sub
Standard Module e.g. Module1
Option Explicit
Sub CombineToMaster()
Const dName As String = "Combined"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drrg As Range
With dws.UsedRange
If .Rows.Count = 1 Then
Set drrg = .Offset(1)
Else
.Resize(.Rows.Count - 1).Offset(1).Clear
Set drrg = .Resize(1).Offset(1)
End If
End With
Dim sws As Worksheet
Dim srg As Range
Dim drg As Range
Dim rCount As Long
For Each sws In wb.Worksheets
If sws.Name <> dName Then
With sws.UsedRange
rCount = .Rows.Count - 1
If rCount > 0 Then
Set srg = .Resize(rCount).Offset(1)
drrg.Resize(rCount).Value = srg.Value
Set drrg = drrg.Offset(rCount)
End If
End With
End If
Next sws
End Sub
VBA Solution
Sub Combine()
Dim wsCombine As Worksheet: Set wsCombine = GetSheetCombine
Dim dataSheets As Collection: Set dataSheets = GetDataSheets
' Copy Header
dataSheets.Item(1).UsedRange.Rows(1).Copy
wsCombine.Range("A1").PasteSpecial xlPasteAll
wsCombine.Range("A1").PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
' Copy data
Dim rngDest As Range: Set rngDest = wsCombine.Range("A2")
Dim srcRng As Range
Dim ws As Worksheet
For Each ws In dataSheets
' Drop header row
With ws.UsedRange
Set srcRng = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
srcRng.Copy rngDest
Set rngDest = rngDest.Offset(srcRng.Rows.Count)
Next ws
Application.CutCopyMode = False
MsgBox "Done!", vbInformation
End Sub
Private Function GetSheetCombine() As Worksheet
Dim ws As Worksheet
With Worksheets
On Error Resume Next
Set ws = .Item("Combine")
On Error GoTo 0
If ws Is Nothing Then
Set ws = .Add(Before:=.Item(1))
ws.Name = "Combine"
Else
ws.Cells.Clear ' clear any existing data
End If
End With
Set GetSheetCombine = ws
End Function
Private Function GetDataSheets() As Collection
Dim Result As New Collection
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Combine" Then Result.Add ws
Next ws
Set GetDataSheets = Result
End Function
As to your question "Will this run every time macro enabled workbook is open?".
No. You will need to put this in a VBA module and run it every time you need, via the Macro dialog (View->Macros), or link a button to it.
Related
I am running a loop through all my worksheets to collcet data on the first worksheet. Now I want to exclude a list of worksheets that is defines by their namees in a list on the first worksheet.
I could exclude them one by one like this:
dim ws as worksheet
For each ws in ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" and ws.name <> "Sheet2"
and so on.
BUT
Since the data will change in the future I dont want to edit this code everytime the "exclude-list" changes.
UPDATE
I have tried the solution from "CLR" because it seemed like an easy way to fix it and it worked for my case. Just a reminder: You also have to include the name of the worksheet you want to diaplay your data on in the list and you are used to the If ws.Name <> "Sheet1" and ws.name <> "Sheet2" method. All the other solutions might work too, when I have the time I might test them, too.
Process worksheets of active workbook, excluding those on a list in a specified range:
Modify the A1:A6 address to the location of your exclusion list. Modify the Sheet1 part if your list is on another named sheet.
Sub ProcessWorksheets()
'declarations
Dim ws As Worksheet
Dim exceptionlist As Range
'define range that contains exceptions
Set exceptionlist = ActiveWorkbook.Worksheets("Sheet1").Range("A1:A6")
'cycle through each worksheet
For Each ws In ThisWorkbook.Worksheets
'if ws.name does not exist in the range
If Application.CountIf(exceptionlist, ws.Name) = 0 Then
'do something with ws
Debug.Print ws.Name
Else
'ignore it, do nothing
End If
Next
End Sub
What you can do is create a sheet named Exclude.
On column A write Exclude on first line.
Your other sheets to exclude after. Finally, use code below..
Dim Lastrow As Integer
Lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rs = ws.Range("A1:A1" & Lastrow)
For Each ws In ThisWorkbook.Worksheets
If Not rs.Find(ws.Name) Is Nothing Then
'Your code
End If
Next
Loop Through Worksheets Excluding the Ones in a List
Test this code as-is before adding your processing code assuring yourself that it works correctly i.e. that it includes the correct worksheets.
Option Explicit
Sub CollectData()
' Define constants.
Const LIST_WORKSHEET_ID = 1 ' rather use the (tab name), e.g. "Sheet1"
Const LIST_FIRST_CELL As String = "Z2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the list range.
Dim lws As Worksheet: Set lws = wb.Sheets(LIST_WORKSHEET_ID)
Dim lfCell As Range: Set lfCell = lws.Range(LIST_FIRST_CELL)
Dim llCell As Range
Set llCell = lws.Cells(lws.Rows.Count, lfCell.Column).End(xlUp)
Dim lrg As Range: Set lrg = lws.Range(lfCell, llCell)
Dim sws As Worksheet
' Loop through all worksheets...
For Each sws In wb.Worksheets
' ... excluding the ones from the list:
If IsError(Application.Match(sws.Name, lrg, 0)) Then
' Continue using the 'sws' variable , e.g.:
Debug.Print sws.Name
'Else ' it's one from the list; do nothing
End If
Next sws
MsgBox "Data collected.", vbInformation
End Sub
How do I make the space before the text disappear without making the space between the texts disappear on every sheet ? I've tried to come up with the following code.
Public Sub Test()
Dim rng As Excel.Range
For Each rng In ActiveSheet.UsedRange 'or change to something like ActiveSheet.Range("A1:A100") for a specific range
rng.Value2 = Trim(rng.Value2)
Next
End Sub
But it's really slow and will only apply to the first sheet out of my 3 sheets. Basically I want to change a cell like " Total Revenue" into "Total Revenue" and would like to apply my code on all 3 sheets I, B and C. Thank you guys in advance !
Trim Ranges
Basic
Note that this will convert any formulas to values.
Sub TrimAllWorksheetsBasic()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' or:
'Set wb = ActiveSheet.Parent ' workbook of the active sheet
Dim ws As Worksheet
For Each ws In wb.Worksheets
ws.UsedRange.Value = Application.Trim(ws.UsedRange.Value)
Next ws
End Sub
Only Cells With Values
Sub TrimAllWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' or:
'Set wb = ActiveSheet.Parent ' workbook of the active sheet
Dim ws As Worksheet, rg As Range, arg As Range
For Each ws In wb.Worksheets
On Error Resume Next
Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
On Error Goto 0
If Not rg Is Nothing Then
For Each arg In rg.Areas
arg.Value = Application.Trim(arg.Value)
Next arg
Set rg = Nothing ' reset for the next iteration
End If
Next ws
End Sub
Specific Worksheets
Sub TrimSpecificWorksheets()
Dim TrimSheets(): TrimSheets = Array("I", "B", "C")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' or:
'Set wb = ActiveSheet.Parent ' workbook of the active sheet
Dim ws As Worksheet, rg As Range, arg As Range
For Each ws In wb.Worksheets(TrimSheets)
On Error Resume Next
Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
On Error Goto 0
If Not rg Is Nothing Then
For Each arg In rg.Areas
arg.Value = Application.Trim(arg.Value)
Next arg
Set rg = Nothing ' reset for the next iteration
End If
Next ws
End Sub
I am trying to skip all of the sheets that are"xlSheetHidden" or "xlSheetVeryHidden". I have recently started using VBA to help speed up processes at my work when python wasn't allowing for what was needed. I currently have the following code:
Sub Merge_Sheets()
Dim Work_Sheets() As String
ReDim Work_Sheets(Sheets.Count)
For i = 0 To Sheets.Count - 1
Work_Sheets(i) = Sheets(i + 1).Name
Next i
Sheets.Add.Name = "Combined Sheet"
Dim Column_Index As Integer
Column_Index = Worksheets(1).UsedRange.Cells(1, 1).Column
Dim Row_Index As Integer
Row_Index = 0
For i = 0 To Sheets.Count - 2
Set Rng = Worksheets(Work_Sheets(i)).UsedRange
Rng.Copy
Worksheets("Combined Sheet").Cells(Row_Index + 1, Column_Index).PasteSpecial Paste:=xlPasteValues
Row_Index = Row_Index + Rng.Rows.Count + 1
Next i
Application.CutCopyMode = False
End Sub
I have tried inserting If .Visible = xlSheetVisible Then but cannot get it to work.
I have also tried to make it work with:
For Each Sheets In ActiveWorkbook.Worksheets
If Sheet.Visible = xlSheetVisible Then
However this still doesn't seem to work, any help would be greatly appreciated.
You did not use the for each correctly. In your code you loop over sheets with the name Sheets, then in the loop you refer to Sheet
For Each Sheets In ActiveWorkbook.Worksheets
If Sheet.Visible = xlSheetVisible Then '// Doesn't work!
So you probaby only needed to fix up this variable naming:
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
Or
For Each sht In ActiveWorkbook.Worksheets
If sht.Visible = xlSheetVisible Then
sht and ws are traditional vba coding variable names for sheet/worksheet objects. But you can use any name you like. However, not Sheets as a variable name, as that is already the name of the built-in Sheets collection.
Merge (Append) Visible Worksheets
Option Explicit
Sub MergeWorksheets()
' Define constants.
Const dName As String = "Combined Sheet"
Const dFirstCellAddress As String = "A1"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
' Delete the destination worksheet ('dws') if it exists.
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
' Write the number of worksheets to a variable ('swsCount').
Dim swsCount As Long: swsCount = wb.Worksheets.Count
' Add the names of all the visible worksheets
' to an array ('WorksheetNames').
' A better choice here is to use a collection or a dictionary
' where it is not important to know the number of elements (items).
' But no harm done.
Dim WorksheetNames() As String: ReDim WorksheetNames(1 To swsCount)
Dim sws As Worksheet ' Current Source Worksheet
Dim n As Long ' Visible Worksheets Count(er)
For Each sws In wb.Worksheets
If sws.Visible = xlSheetVisible Then
n = n + 1
WorksheetNames(n) = sws.Name
End If
Next sws
If n = 0 Then
MsgBox "No visible worksheets found.", vbExclamation
Exit Sub
End If
' Resize the array to the actual number of found visible worksheets
' (not necessary since later we're looping with 'For n = 1 to n').
If n < swsCount Then ReDim Preserve WorksheetNames(1 To n)
' Add and reference a new worksheet, the destination worksheet ('dws').
' First sheet...
Set dws = wb.Worksheets.Add(Before:=wb.Sheets(1))
' ... or e.g. last sheet
'Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName ' rename
' Reference the first cell of the destination range ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim srg As Range ' Current Source Range
Dim drg As Range ' Current Destination Range
For n = 1 To n
' Reference the source worksheet.
Set sws = wb.Worksheets(WorksheetNames(n))
' Reference the used range in the source worksheet.
Set srg = sws.UsedRange
' Reference the destination range, the destination cell
' resized by the number of rows and columns of the source range.
Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
' Write the values from the source range to the destination range.
drg.Value = srg.Value
' Reference the next destination first cell.
Set dfCell = dfCell.Offset(srg.Rows.Count)
Next n
Application.ScreenUpdating = True
' Inform to not wonder if the code has run or not.
MsgBox "Worksheets merged.", vbInformation
End Sub
my code aims to copy the same range from multiple sheets and paste the data from each sheet into the next empty column in a Combined sheet. My code copies from each sheet correctly, but pastes into the same column and overwrites the preceding paste.
Could someone please point out my error?
Many thanks!
Sub CopyToNextCol()
Dim Sh As Worksheet
Dim NextCol As Long
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> "Master" And Sh.Name <> "Lists" And Sh.Name <> "Combined" Then
NextCol = Sheets("Combined").Cells(, Columns.Count).End(xlToLeft).Column + 1
Sh.Range("B2:B44").Copy Sheets("Combined").Cells(, NextCol)
End If
Next Sh
End Sub
Copy Same Ranges From Multiple Worksheets
The following example will copy the worksheet names ("I am planning to use a different column header" in the comments) in the first row and each range below it.
s - Source, d - Destination.
A Quick Fix
Option Explicit
Sub CopyToNextCol()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets("Combined")
Dim dCell As Range
Set dCell = dws.Cells(1, dws.Columns.Count).End(xlToLeft).Offset(, 1)
Dim sws As Worksheet
Dim srg As Range
For Each sws In wb.Worksheets
Select Case sws.Name
Case "Master", "Lists", "Combined"
' Skip (do nothing)
Case Else
Set srg = sws.Range("B2:B44")
dCell.Value = sws.Name
srg.Copy dCell.Offset(1)
Set dCell = dCell.Offset(, 1)
End Select
Next sws
'wb.Save
End Sub
The code below copies all worksheet contents from source workbook into destination workbook. Worksheet names are exactly same. The code copies the data from source in exactly the same order/range ("A2:A700," & _ "D2:D700," & _"C2:C700") into destination workbook. However, I want the data from source in the range above to go into a different range(I3,k3 and AC3) on the destination workbook. Any assistance is appreciated.
Option Explicit
Sub seunweb()
'this macro copies from one workbook to another
Dim wbSource As Workbook, wbDestination As Workbook
Dim ws As Worksheet, rng As Range
Dim NextRow As Long, LastRow As Long
Application.ScreenUpdating = False
Set wbSource = Workbooks.Open("D:\test.xls")
Set wbDestination = ThisWorkbook
For Each ws In wbSource.Sheets
For Each rng In ws.Range("A2:A700," & _
"D2:D700," & _
"C2:C700").Areas
wbDestination.Sheets(ws.Name).Range(rng.Address).Value = rng.Value
Next rng
Next ws
wbSource.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Instead of your for loop, use somthing like
Set rng = ws.Range("A2:A700")
wbDestination.Sheets(ws.Name).Range("I3").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Set rng = ws.Range("D2:D700")
wbDestination.Sheets(ws.Name).Range("K3").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
' continue this this for each source range