Consolidate data from several sheets between two "bookends" into one sheet - excel

I'm looking to tweak some code I already have that consolidates data from multiple sheets into a single, master sheet.
Currently the VBA selects all sheets that starts with the prefix "A-", copies select cells and pastes them into the consolidation sheet.
The change I would like to make is rather than select sheets starting with "A-", instead select all sheets between two sheets. For Simplicity, let's call these "StartSheet" and "EndSheet"
Illustratively it would look something like this:
< startsheet > < analysis1 > < analysis2 > < analysis3 > < endsheet >
Reason being, I, or someone else, can then just drop the analysis sheets between the bookends without risk of lookups and naming conventions.
I've tried a few ways to attempt to fuse my existing code with other examples I have found online but none seem to work. Help greatly appreciated!!
Sub compile()
SelectSheets "A-", ThisWorkbook
'Some other bits and pieces here
End Sub
Sub SelectSheets(sht As String, Optional wbk As Workbook)
Dim wks As Worksheet
Dim ArrWks() As String
Dim I As Long
If wbk Is Nothing Then Set wbk = ActiveWorkbook
ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
If InStr(1, wks.Name, sht) > 0 Then
ArrWks(I) = wks.Name
I = I + 1
End If
Next wks
ReDim Preserve ArrWks(I - 1)
Sheets(ArrWks).Select
Application.ScreenUpdating = False
For Each ws In Sheets(ArrWks)
ws.Range("A23:CU27,A35:CU54,A56:CU58,A62:CU71,A74:CU84").Copy
Worksheets("consol").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Here's the answer!
Sub COMPILE()
Dim i As Long
For i = Sheets("Start").Index + 1 To Sheets("End").Index - 1
Sheets(i).Range("A23:CU27,A35:CU54,A56:CU58,A62:CU71,A74:CU84").Copy
Worksheets("consol").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
End Sub

Related

VBA Copy specific rows from multiple sheets with their names containing "Hawk" and paste into new sheet

I have a workbook containing multiple spreadsheets. Some of these spreadsheets contain the word "Hawk" in their name. For instance, "12345 - HAWK" and "ABCDE - Hawk". I need to copy data from these sheets starting from row 38 down to however many rows that Hawk sheet contains and paste this into a new spreadsheet.
I have this code that I got from another thread, but it is only pasting the rows from the last sheet that contains the word "Hawk". I need it to paste from EVERY sheet that contains "Hawk" in the name, not just the last one.
I don't have any experience in VBA, so I'm not sure what is going wrong. Any advice would be greatly appreciated.
Option Explicit
Sub compile()
SelectSheets "Hawk", ThisWorkbook
'Some other bits and pieces here
End Sub
Sub SelectSheets(sht As String, Optional wbk As Workbook)
Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long
If wbk Is Nothing Then Set wbk = ActiveWorkbook
ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
If InStr(1, wks.Name, sht) > 0 Then
ArrWks(i) = wks.Name
i = i + 1
End If
Next wks
ReDim Preserve ArrWks(i - 1)
Dim ws As Long
For ws = LBound(ArrWks) To UBound(ArrWks)
Worksheets(ArrWks(ws)).Range("A37:AC100").Copy
Worksheets("VBA").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Public Sub compile()
Dim sh As Worksheet, lastrow As Long, lastcol As Long, i As Long
i = 1 'For paste data in first row in MasterSheet.
Sheets("MasterSheet").Cells.ClearContents 'Clear previous data.
For Each sh In ThisWorkbook.Worksheets
If InStr(1, UCase(sh.Name), UCase("HAWK")) > 0 Then
'IF your data is inconsistent then use find function to find lastrow an lastcol.
lastrow = sh.Cells(Rows.Count, 1).End(xlUp).Row
lastcol = sh.Cells(38, Columns.Count).End(xlToLeft).Column
'Here we collect data in master sheet.
Sheets("MasterSheet").Range("A" & i).Resize(lastrow - 38 + 1, lastcol).Value = sh.Range("A38", sh.Cells(lastrow, lastcol)).Value
i = i + lastrow - 38 + 1
End If
Next sh
End Sub
Use this one instead of your code..It will collect all the data from range "A38" to last row and column and paste in mastersheet..Check this and let me know if it works.

Excel VBA Object Invoked has Disconnected from its Clients

So I'm working on a user form to pull data from different excel sheets and build a summary sheet based on user inputs. All of this is within one workbook without external links, and most of the solutions I have seen for this error are the result of trying to connect/open an outside source. The code works until it reaches the tenth entry, then it gives me the Object Invoked has Disconnected from its Clients error and restarts excel. I have tried commenting out the tenth entry and the same error occurs at another interval.
Private Sub Submit_Click()
If TextBox_1.Value > 0 Then
Worksheets("FirstSheet").UsedRange.Offset(3).Resize(Worksheets("FirstSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
If TextBox_2.Value > 0 Then
Worksheets("SecondSheet").UsedRange.Offset(3).Resize(Worksheets("SecondSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
If TextBox_3.Value > 0 Then
Worksheets("ThirdSheet").UsedRange.Offset(3).Resize(Worksheets("ThirdSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
...
If TextBox_9.Value > 0 Then
Worksheets("NinthSheet").UsedRange.Offset(3).Resize(Worksheets("NinthSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
**If TextBox_10.Value > 0 Then
Worksheets("TenthSheet").UsedRange.Offset(3).Resize(Worksheets("TenthSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End if**
Is the issue stemming from the number of repetitions within the code? Is there a specific item within the worksheet itself that I should be looking for that would be causing this issue?
You don't need to specify each sheet separately, you can use a loop like this
Option Explicit
Private Sub Submit_Click()
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Set wb = ThisWorkbook
Set wsTarget = wb.Sheets("Template")
Dim sheetnames As Variant
sheetnames = Array("", "FirstSheet", "SecondSheet", "ThirdSheet", "ForthSheet", _
"FifthSheet", "SixthSheet", "SeventhSheet", "EighthSheet", "NinthSheet", "TenthSheet")
Dim n As Integer, sName As String, sValue As String
Dim rngSource As Range, rngTarget As Range
Application.ScreenUpdating = False
For n = 1 To UBound(sheetnames)
sName = "TextBox_" & CStr(n)
sValue = Me.Controls(sName)
If Len(sValue) > 0 Then
' define ranges
Set wsSource = wb.Sheets(sheetnames(n))
Set rngSource = wsSource.UsedRange.Offset(3).Resize(wsSource.UsedRange.Rows.Count - 3)
Set rngTarget = wsTarget.Rows(4)
' copy to Template
rngSource.Copy
rngTarget.Insert shift:=xlDown
Application.CutCopyMode = False
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
So I was able to get it running last night by splitting the code up and using variables to execute the commands. Not sure why it worked, but it worked.
Private Sub Submit_Click()
Dim Template As Range
Dim FirstSheet As Range
Set Template = Worksheets(2).Range("$A$4")
Set FirstSheet = Worksheets(3).UsedRange.Offset(3).Resize(Worksheets(3).UsedRange.Rows.Count - 3)
If TextBox_1.Value > 0 Then
FirstSheet.Copy
Template.Insert shift:=xlDown
End If

Same workbook in two windows; Sub changes which tab is viewed

I have a workbook that uses a macro to add extra lines, as the workbook has to be heavily locked down to protect it from users. I'm using Excel 2010.
However, if I have two windows open looking at different sheets of the workbook, running the macro makes both windows shift to the sheet in which I added the lines(s), which is disruptive to workflow.
My guess is that this is down to using .PasteSpecial but I am unsure of how else to do it, as the lines to be added include formatting and formulae so .value = .value won't work.
The sub is called from one of four other subs; one to add a single row, one to add multiple rows, one to add a special header row, and one that adds costs rows (done by sending a negative number of rows). The code is:
Sub InsertAnyRows(NumRows As Integer)
Dim thisWS As Worksheet
Set thisWS = ActiveSheet
If Not (InRange(ActiveCell, thisWS.Range("QuoteLines")) Or InRange(ActiveCell, thisWS.Range("LabourLines")) Or InRange(ActiveCell, thisWS.Range("OptionsLines"))) Then Exit Sub
Application.ScreenUpdating = False
Application.CutCopyMode = False
Dim RowLoc As Range
Set RowLoc = thisWS.Cells(Selection.Rows(1).Row, 1)
Select Case NumRows
Case Is < 0 ' must be inserting costs rows
NumRows = NumRows * -1
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("CostsBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case 0 ' must be inserting a header row
RowLoc.Offset(1, 0).EntireRow.Insert
thisWS.Range("TabHeaderRow").Copy
RowLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case Else ' must be inserting normal rows
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("TabBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
End Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This is rather messy and I'm sure there is a more elegant solution, but in a quick test adding these lines after End Select seemed to preserve the windows.
Windows(1).Activate
thisWS.Activate
Windows(2).Activate
Sheets(2).Activate 'adjust sheet name/index to suit
This is what I came up with, so that it'll deal with an arbitrary number of open windows; it also reselects whatever the selection was before running the macro (which looks neater to me). Thank you for the pointers!
Sub InsertAnyRows(NumRows As Integer)
Dim thisWS As Worksheet
Set thisWS = ActiveSheet
If Not (InRange(ActiveCell, thisWS.Range("QuoteLines")) Or InRange(ActiveCell, thisWS.Range("LabourLines")) Or InRange(ActiveCell, thisWS.Range("OptionsLines"))) Then Exit Sub
Application.ScreenUpdating = False
Application.CutCopyMode = False
Dim NumWindows As Integer
NumWindows = ThisWorkbook.Windows.Count
If NumWindows > 1 Then
Dim Windows() As Window
Dim WindowsSheets() As Worksheet
ReDim Windows(NumWindows)
ReDim WindowsSheets(NumWindows)
Dim i As Integer
For i = 1 To NumWindows
Set Windows(i) = ThisWorkbook.Windows(i)
Set WindowsSheets(i) = Windows(i).ActiveSheet
Next i
End If
Dim RowLoc As Range, EndLoc As Range, SelRange As Range
Set SelRange = Selection
Set RowLoc = thisWS.Cells(Selection.Rows(1).Row, 1)
Select Case NumRows
Case Is < 0 ' must be inserting costs rows
NumRows = NumRows * -1
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("CostsBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case 0 ' must be inserting a header row
RowLoc.Offset(1, 0).EntireRow.Insert
thisWS.Range("TabHeaderRow").Copy
RowLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case Else ' must be inserting normal rows
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("TabBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
End Select
SelRange.Select
If NumWindows > 1 Then
For i = NumWindows To 1 Step -1
Windows(i).Activate
WindowsSheets(i).Activate
Next i
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Excel Macro to hide rows across multiple sheets

I have a macro that hides rows based on cell values. I am attempting to use this across multiple sheets in the workbook, but not all of them. My code below seems to run the macro multiple times in the same sheet.
Sub HideRowsWbk()
Dim LastRow As Long
Dim Rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
With ThisWorkbook
For Each ws In .Worksheets
Select Case ws.Name
Case "0000_Index", "000_BidItems", "000_EntrySheet", "000_PayReqs"
'do nothing - exclude these sheets
Case Else
With ws
LastRow = Range("A65536").End(xlUp).Row '
Set Rng = Range("M15:M" & LastRow) 'choose column where value exists
For Each cell In Rng
If cell.Value = "0" Or cell.Value = "-" Then 'checks if cell value is 0 or -
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Select
Next ws
End With
Application.ScreenUpdating = True
End Sub
Please tell me what I have done wrong and how I can fix this. Also please show me how I can improve my minimal coding skills. I am using Excel 2007.
Thank you.
use:
LastRow = .Range("A65536").End(xlUp).Row '
Set Rng = .Range("M15:M" & LastRow) 'choose column where value exists
the "." makes it work with ws

Copy data from a Subset of Worksheets in a workbook and pasting to a master worksheet, disregarding the standard mastersheets

Hello to the community and thank you in advance for your assistance. I have created a workbook that has a variable number of worksheets most of which have variable name. There are however, 4 worksheets that will not change and I do not want data copied from them. The code I am attempting is below: If I am way off base, please let me know.
V/R
Doug
Private Sub GroupReport_Click()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim Disreguard(1 To 4) As String
Disreguard(1) = "RDBMergeSheet"
Disreguard(2) = "0 Lists"
Disreguard(3) = "0 MasterCrewSheet"
Disreguard(4) = "00 Overview"
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> Disreguard.Worksheets.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Rows("21")
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next
Unfortunately, this line will not work for you:
If sh.Name <> Disreguard.Worksheets.Name Then
The Disreguard variable is an array, but not an object in VBA, so there are no methods you can access with the dot operator. You would have to loop through the array's contents and check each item against the string you're testing.
You can add a function to test it like this:
Private Function toDisreguard(ByRef list() as String, ByRef searchString As String) As Boolean
Dim i As Long
For i = LBound(list) To UBound(list)
If (searchString = list(i)) Then
toDisreguard = True
Exit Function
End If
Next i
toDisreguard = False
End Function
And then pass the array along with the sheet name to test like so:
If (toDisreguard(Disreguard, sh.Name) = False) Then
Also, the LastRow() function is not defined from what you posted. Is this a function you created?
In fact, you could just keep track of the last row yourself since you're rebuilding the "RDBMergeSheet" worksheet each time you run this. You can start by setting Last = 1 and then increment along the way. And one last thing, you should probably test to see if there is any data in row 21 for each sheet so you're not copying a blank row:
' Loop through all worksheets and copy the data to the
' summary worksheet.
Last = 1
For Each sh In ActiveWorkbook.Worksheets
If (toDisreguard(Disreguard, sh.Name) = False) Then
'Last = LastRow(DestSh)
If (Application.WorksheetFunction.CountA(sh.Rows("21")) > 0) Then
Set CopyRng = sh.Rows("21")
CopyRng.Copy
With DestSh.Cells(Last, "A") ' notice i changed this as well
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Last = Last + 1
End If
End If
Next

Resources