How to reference source data from another workbook - subscript out of range - excel

I have a dashboard (Sheet "Dashboard") with set of pivot tables that rely on a dynamic data set on a specific sheet of the same workbook (Sheet "Dashboard_Data").
Currently the user is prompted to select a cell on the sheet with the raw data (due to possible different sheet name), the macro then combines the necessary data on the Dashboard Data sheet and the pivot tables are updated.
This works without any problems as long as the raw data is on a sheet in the same workbook.
I am trying to find a solution so that that the user can select the raw data on a sheet that is not in the same workbook. When I run it as is I am getting a subscript out of range error.
Option Explicit
Sub HB_Run_Dashboard()
Dim Ws As Worksheet, lastRow As Long
Dim myNamedRange As Range, Rng As Range, c As Range, destrange As Range
Dim myRangeName As String
Dim desiredSheetName As String
Dim SearchRow As Long
Dim StartatRow As Long
Dim pvt As PivotTable
Dim S As String
'user prompt to locate cell in the sheet with the raw data to capture sheet name
desiredSheetName = Application.InputBox("Select any cell inside the source sheet: ", _
"Prompt for selecting target sheet name", Type:=8).Worksheet.Name
'currently a test code to also have the user find the location of the sheet
'Inputsheetpath = Application.GetOpenFilename(FileFilter:= _
"Excel Workbooks (*.xls*),*.xls*,*.xlsb,*.xlsm", Title:="Open Database File")
'this is where i am stuck. how to set the WS with the correct path info to avoid subscript out of range
Set Ws = Workbook.Worksheets(desiredSheetName)
SearchRow = InputBox("Row # where Reference 'Dashboard' is entered.", "Row Input")
StartatRow = InputBox("Row # where Headers are located.", "Row Input")
'Const SearchRow As Long = SRow
'Const StartAtRow As Long = StRow
Const RangeName As String = "Dashboard_Data_Raw"
lastRow = Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row
'loop cells in row to search...
For Each c In Ws.Range(Ws.Cells(SearchRow, 1), _
Ws.Cells(SearchRow, Columns.Count).End(xlToLeft)).Cells
If LCase(c.Value) = "dashboard" Then 'want this column
'add to range
BuildRange myNamedRange, _
Ws.Range(Ws.Cells(StartatRow, c.Column), Ws.Cells(lastRow, c.Column))
End If
Next c
Debug.Print myNamedRange.Address
Worksheets(desiredSheetName).Names.Add Name:=RangeName, RefersTo:=myNamedRange

Instead of:
Dim desiredSheetName As String
desiredSheetName = Application.InputBox("Select any cell inside the source sheet: ", _
"Prompt for selecting target sheet name", Type:=8).Worksheet.Name
you can do this:
Dim desiredSheet As Worksheet
Set desiredSheet = Application.InputBox("Select any cell inside the source sheet: ", _
"Prompt for selecting target sheet name", Type:=8).Worksheet
Then desiredSheet is a reference to the user-selected worksheet

Related

Filter Row based on value and copy everything below that value into another sheet

I currently have two sheets: Sheet1 and Sheet2.
Sheet1 one consists of system information for items (Source) and Sheet2 is the Destination Sheet (Target).
I need to be able to filter Column A (Source) for the value which is typed into Cell A3 on the Target Sheet and then paste the data into the first available row in the Target sheet. It seems to be failing on the final line of code I'm not really sure why. Appreciate any help.
The error i get is : Run-time error '1004':
Method 'Range' of object'_Worksheet' Failed
Sub CopyRowAndBelowToTarget()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim match As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
Dim lastCopyRow As Long
Dim lastPasteRow As Long
Dim lastCol As Long
Dim matchRow As Long
Dim findMe As String
Sheets("sheet2").Activate
' specify what we're searching for
findMe = Range("B1").Value
'Filter column for value
src.Range("A1").AutoFilter Field:=1, Criteria1:=findMe
' find our search string in column A (1)
Set match = src.Columns(1).Find(What:=findMe, After:=src.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' figure out what row our search string is on
matchRow = match.Row
' get the last row and column with data so we know how much to copy
lastCopyRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
' find out where on our target sheet we should paste the results
lastPasteRow = tgt.Range("A" & src.Rows.Count).End(xlUp).Row
' use copy/paste syntax that doesn't use the clipboard
' and doesn't select or activate
src.Range(Cells(matchRow, 1), src.Cells(lastCopyRow, lastCol)).Copy _
tgt.Range("A" & lastPasteRow)

VBA EXCEL vlookups through all sheets vs index

I have an excel file with over 200 sheets + index sheet, and I am trying to go through all sheets to copy data from index sheet. For example, I have the below table:
A test1
B test2
C test3
D test4
So I would like to do a vlookup in the index sheet, and copy the column K into the right sheet. For example, I would like "test1" to be copied in sheet "A", in cell A3. The table to vlookup is in sheet "INDEX", range J1:K4.
Is that possible? I stored a file here! For confidentiality reason, I've edited sheet names and content, and put a shorter file.
Thanks in advance!
Update Worksheets
Option Explicit
Sub updateWorksheets()
' Define constants.
Const wsName As String = "INDEX"
Const FirstCellAddress As String = "J1"
Const dstAddress As String = "A3"
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Data Range.
Dim rng As Range
With wb.Worksheets(wsName).Range(FirstCellAddress).Resize(, 2)
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - .Row + 1)
End With
' Write values from Data Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Declare additional variables (to be used in the 'For Next' loop).
Dim dst As Worksheet ' Current Destination Worksheet
Dim i As Long ' Data Array Row Counter
' Loop through rows of Data Array.
For i = 1 To UBound(Data, 1)
' Use the value in the first column to try to create a reference
' to the worksheet i.e. check if the worksheet exists.
Set dst = Nothing
On Error Resume Next
Set dst = wb.Worksheets(Data(i, 1))
On Error GoTo 0
' If the worksheet exists,...
If Not dst Is Nothing Then
' ...write value from second column of Data Array
' to Destination Cell Range in Current Destination worksheet.
dst.Range(dstAddress).Value = Data(i, 2)
End If
Next i
End Sub

How to dynamically retrieve the range address of data then change the pivot table data source range address?

I am trying to dynamically retrieve the range address of data then change the pivot table data source range address.
There are three sheets involved.
1) ThisWorkbook.Worksheets("sheet1") - main dashboard, has pivot chart and slicer that were moved from sheet2
2) ThisWorkbook.Worksheets("sheet2") - Pivot Table
3) ThisWorkbook.Worksheets("sheet3") - source data that was copied from different workbook before the below code runs.
My code gives
Run-time error 5: Invalid Procedure call or argument
The error points to Set pt = Pivot_sht.PivotTables(PivotName).ChangePivotCache(pc)
I have two other pivot charts on my main sheet. Using the same code they refresh without any issues.
Full code:
Option Explicit
Sub test()
Dim daMa As Worksheet
Dim daPerf As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim Data_sht As Worksheet
Dim Pivot_sht As Worksheet
Dim DataRange As Range
Dim PivotName As String
Dim NewRangePH As String
Dim pt As PivotTable
Dim pc As PivotCache
'REFRESHING PERFORMANCE HISTORY
'Set Variables Equal to Data Sheet and Pivot Sheet
Set Data_sht = ThisWorkbook.Worksheets("sheet3")
Set Pivot_sht = ThisWorkbook.Worksheets("sheet2")
'Enter in Pivot Table Name
PivotName = "PHPivot"
With Data_sht
.Activate
'Dynamically Retrieve Range Address of Data
LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
LastCol = 12
Set DataRange = Data_sht.Range(Cells(LastRow, 1).Address, Cells(1, LastCol).Address)
End With
NewRangePH = Data_sht.Name & "!" & _
DataRange.Address(ReferenceStyle:=xlR1C1)
'Make sure every column in data set has a heading and is not blank (error prevention)
If WorksheetFunction.CountBlank(DataRange.Rows(1)) > 0 Then
MsgBox "One of your data columns has a blank heading." & vbNewLine _
& "Please fix and re-run!.", vbCritical, "Column Heading Missing!"
Exit Sub
End If
'Change Pivot Table Data Source Range Address
Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRangePH)
Set pt = Pivot_sht.PivotTables(PivotName).ChangePivotCache(pc)
End Sub
I searched through many Google result and results from Stack Overflow and tried at least 10 different things before posting this question.
"set pt = " is worng, you do not want to set a new pivottable.
Instead use
Pivot_sht.PivotTables(PivotName).ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
newRangePH, Version:=xlPivotTableVersion15)

VBA to copy certain columns to all worksheets

Hi I'm looking to create code for copying certain columns (AH to AX) across all worksheets then skipping worksheets named "Aggregated" & "Collated Results"
I have this already
Sub FillSheets()
Dim ws As Worksheets
Dim worksheetsToSkip As Variant
Dim rng As Range
Dim sh As Sheet1
Set rng = sh.Range("AH1:AX7200")
worksheetsToSkip = Array("Aggregated", "Collated Results")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
End Sub
This will
Loop through sheets
"Copy" data from AH1 - AX1 down to the last used row that is determined by Column AH (Update column if needed)
"Paste" data on a sheet named Sheet1 (Update if needed). The data will be pasted in Column AH on the first available blank row. It's not clear what column you want to paste the data in. You just need to change AH to Some Column to modify
"Copy" and "Paste" are in quotes because we are really just transferring values here since this is quicker. We are actually setting the values of two equal sized ranges equal to each other.
Option Explicit
Sub AH_AX()
'Update "Sheet1" to sheet where data is being pasted
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1")
Dim ws As Worksheet, wsLR As Long, msLR As Long
Dim CopyRange As Range, PasteRange As Range
For Each ws In Worksheets
If ws.Name <> "Aggregated" And ws.Name <> "Collated Results" Then
'Determine last rows
wsLR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
msLR = ms.Range("AH" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set Ranges
Set CopyRange = ws.Range("AH1:AX" & LR)
Set PasteRange = ms.Range("AH" & msLR).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count)
'Value Transfer (Quicker than copy/paste)
PasteRange.Value = CopyRange.Value
End If
Next ws
End Sub

merge multiple worksheets into one

I'm trying to merge multiple worksheets into one summary sheet.
Each Worksheet has the name 'Table #number', for example Table 1, Table 2 etc. The layout of each sheet is identical. Data range is columns A1 : N13.
This function doesn't work: =SUM('Table 1':'Table 25'!$A$1:$N$13).
How do I use VBA to amalgamate this data?
Sub MergeSheet()
'Declaring the Variables
Dim LastRow, ShtCnt As Integer
Dim ShtName As String
Dim NewSht As Worksheet
'Assinging a Sheet Name by UserInput
ShtName:
ShtName = InputBox("Enter the Sheet Name you want to create", "Merge Sheet", "Master Sheet")
'Count of Total Worksheet in the present workbook
ShtCnt = Sheets.Count
'Using For Loop check if the worksheet exists
For i = 1 To ShtCnt
If Sheets(i).Name = ShtName Then
MsgBox "Sheet already Exists", , "Merge Sheet"
GoTo ShtName
End If
Next i
'Create a New Sheet
Worksheets.Add.Name = ShtName
'Assigning NewSht as Current Sheet
Set NewSht = ActiveSheet
'Moving Worksheet to the beginning of this workbook
NewSht.Move before:=Worksheets(1)
'Copying all the data to the New Sheet Using For Loop
For i = 2 To ShtCnt + 1
'If i=2 Then copy all the data from the second sheet including header.
If i = 2 Then
Sheets(i).UsedRange.Copy NewSht.Cells(1, 1)
Else
'If i is grater than 2 then copy all the data excluding Header(1st Row).
Sheets(i).UsedRange.Offset(1, 0).Resize(Sheets(i).UsedRange.Rows.Count - 1, Sheets(i).UsedRange.Columns.Count).Copy NewSht.Cells(LastRow + 1, 1)
End If
LastRow = NewSht.Cells.SpecialCells(xlCellTypeLastCell).Row
Next i
'Displaying the Message after copying data successfully
MsgBox "Data has been copied to " & ShtName, , "Merge Sheet"
End Sub
This is a simplified example:
Option Explicit
Sub amalgamateData()
'initialise result variable
Dim myResult As Double
myResult = 0
'loop through sheets to get the sum
Dim wks As Excel.Worksheet 'loop control variable
For Each wks In Excel.ThisWorkbook.Worksheets
If Left(wks.Name, 5) = "Table" Then ' only the "Table" sheets
With wks
Dim rngTarget As Range
myResult = myResult + Excel.Application.WorksheetFunction.Sum(.Range("A1:N13"))
End With
End If
Next
'add result to sheet "Result"
Excel.ThisWorkbook.Sheets("Result").Range("A1") = myResult
End Sub
My starting point was this SO Post: how-to-merge-data-from-multiple-sheets
As Siddharth saud - there loads of references for you on SO HERE IS A SEARCH FOR YOU ... CHECK OUT WHAT IS IN THE BOX IN THE TOP RIGHT OF THE SCREEN

Resources