VBA Embed Loop within a Loop - excel

I'm trying to embed a loop within a loop. I have a workbook with multiple worksheets. What I'm trying to do is identify the range of each worksheet in my workbook and add an additional worksheet for each sheet to create a pivot table. I'm having trouble with embedding my For Loop for worksheet creation in the for loop of setting the worksheet ranges. My current code creates the pivot worksheets and the pivot tables but they all use the range of one worksheet only.
'set pivot table data range
Dim sht As Worksheet
Set wb = ActiveWorkbook
For Each sht In ActiveWorkbook.Worksheets
Set dataRG = sht.Range("A4").CurrentRegion
Next
'verify pvt table sheets in wb
Dim SheetNames() As Variant
SheetNames() = Array("Test1 Pivot", "Test2 Pivot", "Test3
Pivot", "Test4 Pivot", "Test5 Pivot", "Test6 Pivot",
"Test7 Pivot")
For n = LBound(SheetNames) To UBound(SheetNames)
Set pvtWs = Nothing 'reset ws to Nothing
On Error Resume Next 'ignore errors
Set pvtWs = wb.Worksheets(SheetNames(n)) 'try to set `ws`
On Error GoTo 0 'stop ignoring errors
If pvtWs Is Nothing Then 'add a sheet
Set pvtWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
pvtWs.Name = SheetNames(n)
'pivot cache and create pivot
Set pvtCache = ActiveWorkbook.PivotCaches.Create(SourceType:-xlDatabase,SourceData:=dataRG)
Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=pvtWs.Cells(1,1))
pvtTable.Name = PvtNames(n)
End If
Next

It would be cleaner to loop over a list of data sheet names, and use that to drive the logic.
So something like this (untested):
Option Explicit
Sub CheckPivots()
Dim wb As Workbook, nm, wsPivot As Worksheet, wsData As Worksheet
Dim SheetNames, pvNm, pvtCache As PivotCache, pvtTable As PivotTable
Dim rngData As Range
'The names of your sheets with data
SheetNames = Array("Team1", "Team2", "Team3", _
"Team4", "Team5", "Team6", "Team7")
Set wb = ActiveWorkbook
For Each nm In SheetNames
Set wsData = GetSheet(wb, nm)
If Not wsData Is Nothing Then 'data sheet exists?
pvNm = nm & " Pivot" 'name for the pivot sheet
Set wsPivot = GetSheet(wb, pvNm)
If wsPivot Is Nothing Then 'need to add a pivot sheet?
Set wsPivot = wb.Worksheets.Add(after:=wsData)
wsPivot.Name = pvNm
'pivot cache and create pivot
Set rngData = wsData.Range("A4").CurrentRegion
Set pvtCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData)
Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=wsPivot.Cells(1, 1))
pvtTable.Name = "pt_" & nm 'based on source data sheet name
End If
End If
Next nm 'next data sheet name
End Sub
'Return worksheet `nm` from workbook `wb`, or Nothing if no sheet with that name
Function GetSheet(wb As Workbook, wsName) As Worksheet
On Error Resume Next
Set GetSheet = wb.Worksheets(wsName)
End Function

Related

Dynamically Populate All Sheets in Excel Workbook to a Master Sheet

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.

How to change the data source of a PIVOT table Using VBA?

I am new to VBA and need to change the data source of the pivot to 'Sheet1'!$Q$4:$W$1940. The pivot table is present on sheet1 Y1.
Please help with a working code, I have been searching on google but no luck!
Thanks in advance!
Change Pivot Table Data Source
Option Explicit
Sub ChangeDataSource() '
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim pCell As Range: Set pCell = ws.Range("Y3")
Dim ptbl As PivotTable: Set ptbl = pCell.PivotTable
ptbl.ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=ws.Range("Q4:W1940"), Version:=7)
End Sub
I assume that since you are trying to set the range with code, you won't always know the # of rows.
But - you have to know something about the data to ensure it won't get errors. I am assuming that you know there will be data in cell Q4, and in your data set - there will always be a value in column Q.
Sub test()
Dim intLastRow As Integer, intLastColumn As Integer
intLastRow = Sheet1.Range("Q" & Application.Rows.Count).End(xlUp).Row
intLastColumn = Sheet1.Cells(4, Application.Columns.Count).End(xlToLeft).Column
If intLastRow <= 5 Then intLastRow = 5 'need to ensure there's a range to be slected
If intLastColumn <= Sheet1.Range("Q4").Column Then intLastColumn = Sheet1.Range("Q4").Column 'Ensure there's at least one column to select
Sheet1.PivotTables("pvtMyData").ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase _
, SourceData:=Sheet1.Range(Sheet1.Range("Q4"), Sheet1.Cells(intLastRow, intLastColumn)) _
, Version:=8)
End Sub
** note - when you click in a pivot table and then click on the "Pivot Table Analyze" Ribbon, there is an option at the top-left to name your pivot table. In the example, I assume the name is "pvtMyData" - you can use the default name - e.g. "PivotTable5" but it might get confusing.
This will list all sources for all pivot tables in your entire workbook.
Sub PivotSourceListAll()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsList As Worksheet
Dim pt As PivotTable
Dim lPT As Long
Dim wsPT As Worksheet
Dim PTCount As Long
Dim strSD As String
On Error Resume Next
Set wb = ActiveWorkbook
For Each wsPT In wb.Sheets
If wsPT.PivotTables.Count Then
PTCount = PTCount + 1
End If
If PTCount > 0 Then Exit For
Next wsPT
If PTCount = 0 Then
MsgBox "No pivot tables in this workbook"
Exit Sub
End If
Set wsList = Worksheets.Add
With wsList
.Range(.Cells(1, 1), .Cells(1, 3)).Value _
= Array("Sheet", _
"PivotTable", "Source Data")
End With
lPT = 2
For Each ws In wb.Worksheets
For Each pt In ws.PivotTables
strSD = pt.SourceData
If strSD = "" Then strSD = "N/A"
With wsList
.Range(.Cells(lPT, 1), _
.Cells(lPT, 3)).Value _
= Array(ws.Name, pt.Name, strSD)
End With
lPT = lPT + 1
strSD = ""
Next pt
Next ws
With wsList
.Columns("A:C").EntireColumn.AutoFit
.Rows(1).Font.Bold = True
End With
End Sub
Get that working, and it should take much, then you should easily be able to change the source/range of your pivot table to a different source/range.
https://www.contextures.com/excelpivottabledatasource.html

Copy Data from Particular sheets and save in existing sheet"Draft"

I have sheets 1 2 3 4 and all contains the same set of columns(There are other tabs as well in the book with different set of columns).
I need to copy all tab data in to one sheet which is already there in the workbook named "Draft".
I have found this code and tried:
Sub CopyFromWorksheets()
Dim wrk As Workbook
'Workbook object - Always good to work with object variables
Dim sht As Worksheet
'Object for handling worksheets in loop
Dim trg As Worksheet
'Master Worksheet
Dim rng As Range
'Range object
Dim colCount As Integer
'Column count in tables in the worksheets
Set wrk = ActiveWorkbook
'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
which is working fine but creating new tab and copied data from all tabs irrespective of required tab.
which is working fine but creating new tab and copied data from all tabs irrespective of required tab.
Without any testing, and if i understand correctly what you are trying to achieve (copy your Sheet 1,2,3,4 to Draft sheet), please see below the modified code (from your working code):
Sub CopyFromWorksheets()
Dim wrk As Workbook
'Workbook object - Always good to work with object variables
Dim sht As Worksheet
'Object for handling worksheets in loop
Dim trg As Worksheet
'Master Worksheet
Dim rng As Range
'Range object
Dim colCount As Integer
'Column count in tables in the worksheets
Set wrk = ActiveWorkbook
'Working in active workbook
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets("Draft")
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Name = "Sheet1" or sht.Name = "Sheet2" or sht.Name = "Sheet3" or sht.Name = "Sheet4" Then
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

Excel VB Code to Copy Multiple Ranges in Workbook, and Paste in new Workbook

I am looking for a script that will copy a specific range of data, across multiple worksheets, and then paste that data into a brand new Workbook. With my basic knowledge I can do this for a single worksheet in the workbook, but not multiple.
Example, copy cells A7:S1000 from Wkst A and then cells A7:S1000 from Wkst B.
Then paste those cells in a new workbook, on two new worksheets Wkst A and B.
I do not want to save the new workbook, and it must be a brand new workbook that is created each time.
Any suggestions?
Here is an option, you would just pass your range to the DuplicateToNewWB procedure:
Public Function WorksheetExists(wbSource As Workbook, strWorksheet As String) As Boolean
Dim intIndex As Integer
On Error GoTo eHandle
intIndex = Worksheets(strWorksheet).Index
WorksheetExists = True
Exit Function
eHandle:
WorksheetExists = False
End Function
Public Sub DuplicateToNewWB(rngSource As Range)
Dim wbTarget As Workbook 'The new workbook
Dim rngItem As Range 'Used to loop the passed source range
Dim wsSource As Worksheet 'The source worksheet in existing workbook to read
Dim wsTarget As Worksheet 'The worksheet in the new workbook to write
Set wbTarget = Workbooks.Add
For Each rngItem In rngSource
'Assign the source worksheet to that of the current range being copied
Set wsSource = rngItem.Parent
'Assign the target worksheet
If WorksheetExists(wbSource:=wbTarget, strWorksheet:=wsSource.Name) Then
Set wsTarget = wbTarget.Worksheets(wsSource.Name)
Else
Set wsTarget = wbTarget.Worksheets.Add
wsTarget.Name = wsSource.Name
End If
'Copy the value
wsTarget.Range(rngItem.Address) = rngItem
Next
'Cleanup
Set rngItem = Nothing
Set wsSource = Nothing
Set wsTarget = Nothing
Set wbTarget = Nothing
End Sub

Copy data from one workbook to another "Object Required"

I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")

Resources