Macro to copy first two columns from all sheets to a master sheet is skipping sheets - vba

I'm using this macro to copy columns A and B from all of my sheets into a new sheet named Master. What I notice is that entire sheets worth of information are missing in the master sheet and I can't figure out why. The format for my sheets is column A has a string of characters that follow this structure: M2,004,005,004,007,17,096,01:07:45,45 and column B is just a date such as 4/19/2017.
I have hundreds of these sheets in my workbook and each has 224 rows that I need to copy into a single master sheet. Could anyone help me figure out how to get this code to stop skipping sheets?
Thanks.
Sub CreateMaster()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Master"
Sheets(2).Activate
Range("A1:B1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1:B1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1:B1").Select
Selection.CurrentRegion.Select
Selection.Copy Destination:=Sheets(1).Range("A65536:B65536").End(xlUp)(2)
Next
End Sub
while searching for solutions online, I came across this macro that seems to do the same thing, but also seems to skip the exact same sheets as my macro does.
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
as a workaround, since only the most recent data is immediately pertinent, I worked around it, but deleting the first 150 sheets. that still left around 100 sheets for my macro to work on, but now the missing pieces of data seem to be there. I wonder if there's something about the quantity of sheets that is causing this to malfunction?

Comments may not get it across correctly. Restructure your loop (and add the variables mentioned).
Dim x as Long
Dim thisSht as Worksheet
For x = 1 to wrk.Worksheets.Count
set thisSht = wrk.Worksheets(x)
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = thisSht.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 x

Related

Finding the address of a table range using vba

I am working with an excel sheet that has a bunch of sheets with data in tables. I am trying to consolidate the sheets. I do not want the copied data to be in tables. I am able to find the tables range address for all the sheets except one, which is retunring an address of $1:$104. All the other ranged are like this "$A$1:$J$43" . When I try to copy this table using the address it returns , I get the runtime error "1004". For now , the code rewrite all the tables in the same place, but I will be changing the code to copy the tables into different places in the destination sheet.
Here is my code:
Sub mergeWorksheets()
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
Dim mLastRow As Integer
Dim LastRow As Integer
Dim rngFound As Range
Dim i As Integer
Set wrk = ActiveWorkbook 'Working in active workbook
'We don't want screen updating
Application.ScreenUpdating = False
' would rather not do a loop but using a function to check and delete sheet renders error
For Each Sheet In ActiveWorkbook.Worksheets
If Sheet.Name = "Master" Then
Application.DisplayAlerts = False
Sheets("Master").Delete
Application.DisplayAlerts = True
End If
Next Sheet
' Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(Before:=wrk.Worksheets(1))
' Rename the new worksheet
trg.Name = "Master"
'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 Like "*Attri*" Then
Debug.Print sht.Name
'Find the last row of the master sheet
Set rngFound = trg.UsedRange.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
If Not rngFound Is Nothing Then
'you found the value - do something
mLastRow = rngFound.Row
Debug.Print "Last row of master " & rngFound.Address, mLastRow
Else
' you didn't find anything becasue sheet is empty - first pass
mLastRow = 0
End If
For Each tbl In sht.ListObjects
'Do something to all the tables...
Debug.Print tbl.Name
Debug.Print tbl.Range.Address
'Put data into the Master worksheet
tbl.Range.Copy Destination:=trg.Range("B1")
Next tbl
' trg.Cells(mLastRow + 1, 1).Value = "Tab Name"
' trg.Cells(mLastRow + 1, 1).Font.Bold = "True"
' trg.Range("A" & mLastRow + 1).Value = sht.Name
Debug.Print "-------"
Else
' Debug.Print "error " & sht.Name & " is missing header "
End If
Next sht
That funny range is obviously there. What you can do is to control the size of the data to be copied. If you can set a meaningful maximum value for table width then you can limit size like this:
const MAXWID = 1000
Dim r As Range
If tbl.Range.Columns.Count > MAXWID Then
Set r = tbl.Range.Resize(, MAXWID)
Else
Set r = tbl.Range
End If
r.Copy Destination:=trg.Range("B1")
Funny things can happen to the height of the table(s), too, so you may want to implement this for the other dimension. For appending the tables you need to know where the first empty row is:
FirstEmptyRow = trg.Range("B1").SpecialCells(xlCellTypeLastCell).Row + 1
r.Copy Destination:=trg.Cells(FirstEmptyRow, "B")
For sheet manipulation you need to use On Error ... like this:
Application.DisplayAlerts = False
On Error Resume Next
Set trg = wrk.Sheets("Master")
If Err.Number = 0 Then ' sheet exists
trg.Usedrange.Delete ' delete all existing data -> have a clean sheet
Else ' sheet doesn't exist, Add new worksheet as the first worksheet
Set trg = wrk.Worksheets.Add(Before:=wrk.Worksheets(1))
If Err.Number <> 0 Then < sheet is not added, handle error...>
trg.Name = "Master"
End If
On Error Goto 0
Application.DisplayAlerts = True
It's worth taking the time to learn how error handling works in VBA.
And finally: use Option Explicit. It pays.

Excel VBA: If statement to copy/paste into a new worksheet then delete rows of what was copied

Just started learning VBA today to try to make life a bit easier at my new job. I'm essentially trying to look for every instance where column E has the letter "a" copy and paste it into a newly created worksheet called "Aton" then delete the original rows with the "a"s.
I tried to modify the solution found here: VBA: Copy and paste entire row based on if then statement / loop and push to 3 new sheets
When I changed the above solution to make this line "If wsSrc.Cells(i, "E").Value = "a" Then" that's when I run into problems.
Sub Macro3()
'Need "Dim"
'Recommend "Long" rather than "Integer" for referring to rows and columns
'i As Integer
Dim i As Long
'Declare "Number"
Dim Number As Long
'Declare a variable to refer to the sheet you are going to copy from
Dim wsSrc As Worksheet
Set wsSrc = ActiveSheet
'Declare a variable to refer to the sheet you are going to copy to
Dim wsDest As Worksheet
'Declare three other worksheet variables for the three potential destinations
Dim wsEqualA As Worksheet
'Create the three sheets - do this once rather than in the loop
Set wsEqualA = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Assign the worksheet names
wsEqualA.Name = "Aton"
'Determine last row in source sheet
Number = wsSrc.Cells(wsSrc.Rows.Count, "C").End(xlUp).Row
For i = 1 To Number
'Determine which destination sheet to use
If wsSrc.Cells(i, "E").Value = "a" Then
Set wsDest = wsEqualA
Else
End If
'Copy the current row from the source sheet to the next available row on the
'destination sheet
With wsDest
wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
'Delete row if column E has an a
If wsSrc.Cells(i, "E").Value = "a" Then
Selection.EntireRow.Delete
Else
End If
Next i
End Sub
Sticking to your code, you have three issues
when deleting rows you have to loop backwards and avoid skipping rows
you’re copying and (trying to) deleting rows outside the ‘If wsSrc.Cells(i, "E").Value = "a"‘ block, hence regardless of current row “i” column E value
you don’t want to delete currently selected range rows, but currently loop “i” row
Putting it all together here’s the correct relevant snippet;
Set wsDest = wsEqualA 'set target sheet once and for all outside the loop
For i = Number To 1 Step -1 'Loop backwards
If wsSrc.Cells(i, "E").Value = "a" Then
'Copy the current row from the source sheet to the next available row on the destination sheet
With wsDest
wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copy wsSrc current “i” row and paste it to wsDest
wsSrc.Rows(i).Delete 'Delete wsSrc current “i” row
End With
End If
Next
As a possible enhancement, you could swap the sheets references in the “With...End With” block, since it’s more effective to reference the mostly “used” one:
With wsSrc
.Rows(i).Copy wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copy wsSrc current “i” row and paste it to wsDest
.Rows(i).Delete 'Delete wsSrc current “i” row
End With
You need to qualify which sheet the original values are on. Change Sheet on the line Set ws = ThisWorkbook.Sheets("Sheet1") to your sheet name.
Create new sheet and set objects
Create range to loop through, LoopRange (E2 down to last row in column)
Loop through LoopRange. If criteria is met, add the cell, MyCell, to a collection of cells (TargetRange)
If the TargetRange is not empty (meaning your criteria was met at least once) then copy header from ws to ns
Copy TargetRange from ws to ns
Delete TargetRange from ws
The benifit if using Union to collect cells is that you avoid many iterations of copy/paste/delete. If you have 50 cells in your range that meet your criteria, you will have 50 instance each for copy/paste/delete for a grand total of 150 actions.
Using the Union method, you will just have 1 instance for each action for a grand total of 3 actions which will boost run time.
Option Explicit
Sub Learning()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ns As Worksheet: Set ns = Worksheets.Add(After:=(ThisWorkbook.Sheets.Count)) 'ns = new sheet
ns.Name = "Aton"
Dim LoopRange As Range, MyCell As Range, TargetRange As Range
Set LoopRange = ws.Range("E2:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row)
For Each MyCell In LoopRange 'Loop through column E
If MyCell = "a" Then
If TargetRange Is Nothing Then 'If no range has been set yet
Set TargetRange = MyCell
Else 'If a range has already been set
Set TargetRange = Union(TargetRange, MyCell)
End If
End If
Next MyCell
Application.ScreenUpdating = False
If Not TargetRange Is Nothing Then 'Make sure you don't try to copy a empty range
ws.Range("A1").EntireRow.Copy ns.Range("A1") 'copy header from original sheet
TargetRange.EntireRow.Copy ns.Range("A2")
TargetRange.EntireRow.Delete
Else
MsgBox "No cells were found in Column E with value of 'a'"
End If
Application.ScreenUpdating = True
End Sub
First, don't use ActiveSheet, it can cause multiple problems. If sheet1 is not your source worksheet then change it to meet your needs. I prefer using a filter, as urdearboy suggested, which dosn't require a loop and is faster. I always try to keep the code simple, so try this...
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Aton"
With Sheet1.UsedRange
.AutoFilter Field:=5, Criteria1:="a", Operator:=xlFilterValues
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Aton").Range("A1")
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With

Dynamically copy a worksheet multiple times and rename using VBA in Excel

I am trying to dynamically generate a custom number of worksheets based on a template that we use regularly in excel using VBA.
I have created an "Overview" page where we can input a range which will be used to name the new worksheets but then would like to use a hidden "Master" worksheet to generate the content of these new worksheets.
My code below currently generates the correct number of pages based on the range AND copies our master template page but does not combine the two and leaves them in separate pages.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set masterSheet = ThisWorkbook.Worksheets("Master")
Set MyNames = Range("A1:A6").CurrentRegion ' load range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell range
masterSheet.Copy ThisWorkbook.Sheets(Sheets.Count) 'copy master template sheet
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
As you can see, the code generates both the named (blank) worksheets AND copies my master worksheet which defaults to naming as "Master()".
So we just need to replace this line:
Sheets.Add.Name = MyNewSheet.Value
with this line:
ActiveSheet.Name = MyNewSheet.Value
Loop through the list and copy the sheet if the sheet does not already exist.
Sub CopyMaster()
Dim ws As Worksheet, sh As Worksheet
Dim Rws As Long, rng As Range, c As Range
Set sh = Sheets("Overview")
Set ws = Sheets("Master")
With sh
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
End With
For Each c In rng.Cells
If WorksheetExists(c.Value) Then
MsgBox "Sheet " & c & " exists"
Else:
ws.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = c.Value
End If
Next c
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function

AdvancedFilter CopyToRange:= First empty row

I am trying to use AdvancedFilter in VBA, but instead of setting copy to range to a fixed value I want to copy it to the first empty row.
I am trying to append two tables from two separate AdvancedFilter steps, is there an easier way? E.g. first copy the two tables to separate location and then merge them? Both table have the same columns.
My code as of now is:
Set rngCriteria_v = Sheets("1").Range("filter")
Set rngExtract_v = Sheets("2").Range("**Here first empty row**")
Set rngData_v = Sheets("3").Range("Input")
rngData_v.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria_v, _
CopyToRange:=Sheets("Stocks_5_control").Columns("AG").Find(vbNullString, Cells(Rows.Count, "AG")), _
Unique:=False
Change your advanced filter line to this:
rngData_v.AdvancedFilter xlFilterCopy, rngCriteria_v, Sheets("Stocks_5_control").Cells(Sheets("Stocks_5_control").Rows.Count, "AG").End(xlUp)(2)
The following merges the all the worksheets in to a new sheet called Master. Hope that helps :)
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
Dim wd As Object 'used for word document
Dim WDoc As Object
Dim strWorkbookName As String
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
'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

Allow append of data to a summary sheet in another workbook

I have this code which appends data from three worksheets to a summary sheet, however on execution it is taking 12 of the 13 rows from sheet 1 and 2 and thirteen from sheet 3 to the summary I also would like this to work by sending to a summary sheet in a different workbook
Sub SummurizeSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("D2:D6, D8:D15").Copy
Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp).Offset(0, 0).PasteSpecial (xlPasteValues)
End If
Next ws
End Sub
Change Offset(0,0) to Offset(1,0). What's happening is not that it's copying 12 rows, but rather that the subsequent blocks are being pasted starting at the end of the previous block. That is, the first block is pasted into D1:D13, and the second block is pasted into D13:D26. By using Offset(1,0), the second block will be pasted starting with the first empty cell (that is, D14).
You can place the results in a new workbook simply by creating it in the code and referring to it in the paste, for example:
Option Explicit
Sub SummurizeSheets()
Dim ws As Worksheet
Dim currentWB As Workbook: Set currentWB = ActiveWorkbook
Dim newWB As Workbook: Set newWB = Application.Workbooks.Add
newWB.Worksheets(1).Name = "Summary"
For Each ws In currentWB.Worksheets
ws.Range("D2:D6, D8:D15").Copy
With newWB.Worksheets("Summary").Cells(Rows.Count, 4).End(xlUp)
If IsEmpty(.Value) Then
.PasteSpecial (xlPasteValues)
Else
.Offset(1, 0).PasteSpecial (xlPasteValues)
End If
End With
Next ws
End Sub
EDIT updated to paste into the first empty cell in column, even if that is row 1.