I am trying to combine numerous sheets into one new sheet. I would really appreciate any comments.
The issue is with the line:
wsSrc.Range("A1", wsSrc.Range("D", lastRow)).Copy Destination:=rngDest
Which causes the error when I try to run it. I have previously been using the code to combine all the sheets into the sheet Summary which is where the button for the macro is created which worked fine.
Sub mcrCombine()
ActiveWorkbook.Sheets.Add.Name = "Combined" 'Create new sheet
'Definitions
Dim wsSrc As Worksheet
Dim wsDest As Worksheet
Dim rngDest As Range
Dim lastRow As Long
Dim destRow As Long
Set wsDest = Worksheets("Combined") 'Destination sheet in same Workbook
Set rngDest = wsDest.Range("B1") 'Destination cell in Combined
Application.DisplayAlerts = False 'suppress prompt worksheet delete
'loop through all sheets
For Each wsSrc In ThisWorkbook.Sheets
If wsSrc.Name <> "Summary" And wsSrc.Name <> "Combined" Then 'all sheets except summary
lastRow = wsSrc.Cells.SpecialCells(xlCellTypeLastCell).Row 'define last row
wsSrc.Range("A1", wsSrc.Range("D", lastRow)).Copy Destination:=rngDest 'copy and paste data in range
Set rngDest = rngDest.Offset(lastRow - 1) 'update destination range
wsSrc.Delete 'delete source file
End If
Next
Application.DisplayAlerts = True 'prompts back on
End Sub
OK, I am not sure that this will get your code to achieve all what it is supposed to do, but since you corrected to issue pointed out by #Jeeped and specified your issue within this line:
wsSrc.Range("A1", wsSrc.Range("D", lastRow)).Copy Destination:=rngDest
The error in this line is because of the comma instead of the ampersand. You should change it into:
wsSrc.Range("A1", "D" & lastRow).Copy Destination:=rngDest
Hope this helps.
I have previously been using the code to combine all the sheets into the sheet Summary which is where the button for the macro is created which worked fine.
That's the clue as to what is occurring. As you cycle through each of the worksheets in the workbook you take care not to process the Summary worksheet; probably because a) it already holds aggregated information from the other worksheets and b) you do not want it deleted with the other worksheets that are processed.
If you have changed the central location to a Combined worksheet you are going to have to include that in the worksheet(s) to skip over. Failure to skip over the Combined worksheet will a) copy its content on top of itself and b) delete the Combined worksheet.
If wsSrc.Name <> "Summary" And wsSrc.Name <> "Combined" Then
If you delete the Combined worksheet, then there is Nothing in the way of a destination.
Related
I had a working program that uses Sheet1 and Sheet2 in the code. However, now I realized that if I remove Sheet2 and create new sheet that sheet number is no longer being used. What I actually need to do is to create another sheet if only 1 exists and then use that in my code. However, my trials have not worked so far. I used to have code like this to define variables:
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Set datasheet = Sheet1
set reportsheet = Sheet2
Of course this doesnt work anymore since I deleted Sheet2 and excel remembers your past mistakes. I tried to circumvent this by doing following:
Set datasheet = Sheet1
'Create reportsheet if it doesnt exist
Dim ws As Worksheet
CreateSheetIf = False
Set ws = Nothing
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets("reportdata")
On Error GoTo 0
If ws Is Nothing Then
CreateSheetIf = True
Worksheets.Add.Name = "reportdata"
End If
Set reportsheet = ws
Unfortunately, here I run into an error in my later code which tries to empty the reportsheet:
reportsheet.Range("A1:H200").ClearContents
What I would like to have is to create a new sheet in addition to sheet1 if there is none. This sheet should be located after the Sheet1 in the sheet listing. My further code would utilize this as the reportsheet (I move data from Sheet1 to Sheet2). Someone has any tips on what I am doing wrong and how to do it better?
You do not need to rename the sheet, or have it called Sheet1 and Sheet2. You could access it dynamically relative to their index. For example:
Set datasheet = Worksheets(1) ' The first sheet in the workbook
set reportsheet = Worksheets(2) ' The second sheet in the workbook
I see lack of focus there, you first try to refer to worksheets by Object name (Sheet1, Sheet2) and then by Tab name ("reportdata").
Set ws = ActiveWorkbook.Worksheets("reportdata") with error supression is a good way to handle it, although you try to do the following after:
Set reportsheet = ws
The problem is that if you go through code, you will notice that at this stage Object ws is Nothing if there was no "reportdata" worksheet prior to running this code.
Use:
Set reportsheet = ActiveWorkbook.Worksheets("reportdata")
You can use the worksheet index number instead of the codename.
Option Explicit
Sub repBuild()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Set datasheet = Sheet1
On Error GoTo createSecondWs
Set reportsheet = Worksheets(2)
On Error GoTo 0
'build report here with reportsheet
Exit Sub
createSecondWs:
With Worksheets.Add(after:=Worksheets(Worksheets.Count))
.Name = "Report Sheet"
'perform other basic report template operations here before returning
End With
Resume
End Sub
This uses error control to create a second worksheet if only one exists.
I have three workbooks.
One workbook is a list I add to every month, of things I need to delete from a second workbook. I receive a second workbook every month. The second workbook I receive always contains extraneous entries (the number growing every month) and will not be fixed anytime soon. There is no general filter I can make without making the second workbook useless, so I need to be really specific and have a silly cleaning list.
My third workbook is where I run all of my workbook cleaning macros from.
The objective is to compare the entries in column A or B on the first workbook with the entries in column A or B of the second workbook I receive. If any of the entries match, delete the entire row on the second workbook.
I will be doing this once a month for a few hundred lines, and it will be run from a macro assigned to a shape on a third workbook.
Here I am posting some code that lets me open my two files and copy the contents of one of them, but what I need is code that will compare and delete rows on Workbook 2 that match with Workbook 1. My own code to do exactly that is terrible, not worth posting at all.
Code:
Sub test()
Dim strFileName As String
Dim wbTarget As Workbook
Dim wbSource As Workbook
Dim wsTarget As Worksheet
Dim wsSource As Worksheet
strFileName = Application.GetOpenFilename("Excel files (*.xls*),*.xl*", Title:="Open data")
Set wbSource = ThisWorkbook
Set wbTarget = Workbooks.Open(strFileName)
Set wsSource = wbSource.Worksheets("Sheet1")
Set wsTarget = wbTarget.Worksheets("Sheet1")
'to copy from Target - > Source
wsTarget.Range("B2").Resize(5, 5).Copy wsSource.Range("B2")
'etc.
End Sub
Code, comment and suggestion is greatly appreciated!
Cheers,
Christopher
CODE UPDATE 8:30 AM: This is a new way I am thinking of making things work. I am getting a type mismatch error on the code line Set Rng = Range("A1:B10000" & LR)
Sub test()
Dim strFileName As String
Dim strFileName2 As String
Dim wbTarget As Workbook
Dim wbSource As Workbook
Dim wsTarget As Worksheet
Dim wsSource As Worksheet
Dim LR
Dim Rng As Range
strFileName = Application.GetOpenFilename("Excel files (*.xls*),*.xl*", Title:="Open 'Things Which Have Been Removed'")
strFileName2 = Application.GetOpenFilename("Excel files (*.xls*),*.xl*", Title:="Open This Month's Purge List")
Set wbSource = ThisWorkbook
Set wbTarget = Workbooks.Open(strFileName)
Set wsSource = wbSource.Worksheets("Sheet1")
Set wsTarget = wbTarget.Worksheets("Sheet1")
Set LR = wsSource.UsedRange.Rows
With wbTarget.Sheets(1)
Set Rng = Range("A1:B10000" & LR)
Rng.RemoveDuplicates Columns:=Array(4), Header:=xlNo
End With
End Sub
To answer your specific question.
Set Rng = Range("A1:B10000" & LR)
Should be
Set Rng = Range("A1:B" & LR)
I would like to help with your other issues, but your description is confusing, this is what I understand; you identify bad information in the second workbook and copy that information from the second workbook to the first workbook, then you want a macro to match what is in the first workbook to the second workbook and delete the rows in the second workbook that match. Question, why don't you delete the rows in the second workbook instead of copying them to the first workbook?
You can use find method ; after open workbook u can use this code, findind the cell adress u can easily delete it clear command
Dim GCell As Range
Set GCell = ActiveSheet.Cells.Find("yourvariable")
I got some script here to open up multiple workbooks with a worksheet and then copy it to a worksheet as a loop, but I need an additional cell (the date) from another worksheet in the multiple workbooks because the output I got cannot be changed and just added to the same sheet.
What I need is for this code to include a single cell range from another sheet on the workbook and then fill it to the bottom of the range per workbook.
I cant use UNION as it's not the same length, and I looked up merging ranges into one, but I get type mismatch errors.
VBA: How to combine two ranges on different sheets into one, to loop through I tried this but I can't figure out how to put it into my code.
Here is the code I have that works so far for just the one range. The rngdate copies over but does not leave a gap or autofill to the next loop, it just pastes under each other, so maybe this code will work but I'm missing something basic like autofill?
Dim vFileNames As Variant
Dim y As Long
Dim wbTemp As Workbook
Dim wbNew As Workbook
Dim blHeader As Boolean
Dim Rng As Range
Dim rngDate As Range
Application.ScreenUpdating = False
Set wbNew = Workbooks("master_timesheet") '.Add
blHeader = False
vFileNames = Application.GetOpenFilename(Title:="Select all workbooks to copy", _
MultiSelect:=True)
'Will not be array if no file is selected
'If user selects one or more files, files will be stored as an array
If Not IsArray(vFileNames) Then GoTo ConsolidateWB_End
For y = LBound(vFileNames) To UBound(vFileNames)
'Open each wb selected
Set wbTemp = Workbooks.Open(vFileNames(y))
Set rngDate = wbTemp.Worksheets("Communications Unlimited Inc").Range("A5").CurrentRegion
Set Rng = wbTemp.Worksheets("Export").Range("A1").CurrentRegion
'If header row already copied, then offset by 1 to exclude header
If blHeader Then
Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)
'If header row not already copied, keep rng as is and change blHeader to true
Else
blHeader = True
End If
'Paste to next row on new wb
Rng.Copy Destination:=wbNew.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
rngDate.Copy Destination:=wbNew.Sheets(1).Range("P65536").End(xlUp).Offset(1, 0)
wbTemp.Close SaveChanges:=False
Next y
ConsolidateWB_End:
Application.ScreenUpdating = True
End Sub
If I read your problem correctly you want the date, rngdate, pasted adjacent to each and every line of data you have just copied. However your current code only puts the data on the first row. Below is an adaptation of how I have solved this problem myself, taking account of your existing code. (My guess is that there is a much more elegant solution than this which I'm just not aware.)
Dim pasterangefirstrow As Integer
...
pasterangefirstrow = wbNew.Sheets(1).Range("D65536").End(xlUp).Offset(1, 0).Row
...
With wbNewSheets(1)
Rng.Copy Destination:=.Range("D65536").End(xlUp).Offset(1, 0)
rngdate.Copy Destination:=.Range("P" & pasterangefirstrow & ":P" & pasterangefirstrow + Rng.Rows.Count - 1)
End With
I have a plethora of Excel workbooks containing 25+ worksheets each containing 20 columns of data from range 1:500 (or 1:1000 in some cases). Frequently I am tasked with updating the "template" onto which new data is entered for new calculations. I want to be able to easily paste extant data from old worksheets into sheets with new formatting while retaining any new formatting/formulas in the new templates.
I am using VBA to open the sheet I want to copy and paste it onto the new template sheet. So far my code will copy everything from the first sheet (S1) of the to-be-copied workbook and paste it onto the first sheet (S1) of the target workbook.
I want to extend this process to go through all active sheets (do whatever it is doing now for each sheet in the workbooks). I previously was able to do this with different code but it removed the formulas in rows 503 and 506 that I need when it pasted in. Can I do a pastespecial and skip empty cells? I am new to this.
Here is my current code:
Sub CopyWS1()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks("Ch00 Avoid.xlsx")
Set y = Workbooks("Ch00 Avoid1.xlsx")
Dim LastRow As Long
Dim NextRow As Long
x.Worksheets("S1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row
Range("A2:T" & LastRow).Copy y.Worksheets("s1").Range("A1:A500")
Application.CutCopyMode = False
Range("A1").Select
End Sub
I believe that I need to use something like the following code in order to extend this across the worksheets, but I'm not sure how to iterate through the sheets since I'm specifically referencing two sheets in my above code.
Sub WorksheetLoop2()
' Declare Current as a worksheet object variable.
Dim Current As Worksheet
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
' Insert your code here.
' This line displays the worksheet name in a message box.
MsgBox Current.Name
Next
End Sub
I imagine that I might be able to solve this as a for loop across an index of worksheets (make a new variable and run a for loop until my index is 25 or something) as an alternative, but again, I'm not sure how to point my copy/paste from a particular sheet to another sheet. I am very new to this with semi-limited experience with Python/Java only. These VBA skills would greatly benefit me on the day to day.
The two files in question:
Ch00 Avoid
Ch00 Avoid1
This should do it. You should be able to drop this in a blank workbook just to see how it works (put some values in column A on a couple of sheets). Obviously you will replace your wbCopy and wbPaste variables, and remove the wbPaste.worksheets.add from the code (my excel was only adding 1 sheet in the new workbook). LastRow is determined per your code, looking up from column A to find the last cell. wsNameCode is used to determine the first part of your worksheets you are looking for, so you will change it to "s".
This will loop through all sheets in your copy workbook. For each of those sheets, it's going to loop 1 through 20 to see if the name equals "s" + loop number. Your wbPaste has the same sheet names, so when it finds s# on wbCopy, it is going to paste into wbPaste with the same sheet name: s1 into s1, s20 into s20, etc. I didn't put in any error handling, so if you have an s21 on your copy workbook, s21 needs to be on your paste workbook, and NumberToCopy changed to 21 (or just set it to a higher number if you plan on adding more).
You could have it just loop through the first 20 sheets, but if someone moves one it will throw it all off. This way sheet placement in the workbook is irrelevant as long as it exists in the paste workbook.
You can also turn screenupdating off if you don't want to have a seizure.
Option Explicit
Sub CopyAll()
'Define variables
Dim wbCopy As Workbook
Dim wsCopy As Worksheet
Dim wbPaste As Workbook
Dim LastRow As Long
Dim i As Integer
Dim wsNameCode As String
Dim NumberToCopy As Integer
'Set variables
i = 1
NumberToCopy = 20
wsNameCode = "Sheet"
'Set these to your workbooks
Set wbCopy = ThisWorkbook
Set wbPaste = Workbooks.Add
'These are just an example, delete when you run in your workbooks
wbPaste.Worksheets.Add
wbPaste.Worksheets.Add
'Loop through all worksheets in copy workbook
For Each wsCopy In wbCopy.Worksheets
'Reset the last row to the worksheet, reset the sheet number search to 1
LastRow = wsCopy.Cells(65536, 1).End(xlUp).Row
i = 1
'Test worksheet name to match template code (s + number)
Do Until i > NumberToCopy
If wsCopy.Name = (wsNameCode & i) Then
wsCopy.Range("A2:T" & LastRow).Copy
wbPaste.Sheets(wsNameCode & i).Paste
End If
i = i + 1
Loop
Next wsCopy
End Sub
Thank you for all of your help, everyone. I went back yesterday afternoon from scratch and ended up with the following code which, at least to my eyes, has solved what I was trying to do. The next step will be to try to make this less tedious as I have a gajillion workbooks to update. If I can find a less obnoxious way to open/update/save/close new workbooks, I will be very happy. As it stands now, however, I have to open both the example workbook and the target workbook, save both, and close...but it works.
'This VBA macro copies a range of cells from specified worksheets within one workbook to a range of cells
'on another workbook; the names of the sheets in both workbooks should be identical although can be edited to fit
Sub CopyToNewTemplate()
Dim x As Workbook
Dim y As Workbook
Dim ws As Worksheet
Dim tbc As Range
Dim targ As Range
Dim InxW As Long
Dim WshtNames As Variant
Dim WshtNameCrnt As Variant
'Specify the Workbook to copy from (x) and the workbook to copy to (y)
Set x = Workbooks("Ch00 Avoid.xlsx")
Set y = Workbooks("Ch00 Avoid1.xlsx")
'Can change the worksheet names according to what is in your workbook; both worksheets must be identical
WshtNames = Array("S1", "S2", "S3", "S4", "S5", "S6", "S7", "s8", "s9", "S10", "S11", "S12", "S13", "S14", "S15", _
"S16", "S17", "S18", "S19", "S20", "Ext1", "Ext2", "Ext3", "EFS BigAverage")
'will iterate through each worksheet in the array, copying the tbc range and pasting to the targ range
For Each WshtNameCrnt In WshtNames
With Worksheets(WshtNameCrnt)
'tbc is tobecopied, specify the range of cells to copy; targ is the target workbook range
Set tbc = x.Worksheets(WshtNameCrnt).Range("A1:T500")
Set targ = y.Worksheets(WshtNameCrnt).Range("A1:T500")
Dim LastRow As Long
Dim NextRow As Long
tbc.Copy targ
Application.CutCopyMode = False
End With
Next WshtNameCrnt
End Sub
I have a workbook named Test and wrote a macros with the code below. It worked fine, but when I added it to my personal workbook, the code gave an error on line Set ws = ThisWorkbook.Sheets("Sheet1").
Subscript out of range.
I moved the code from a module to the Sheet1 on the Personal Workbook and then to the ThisWorkbook. Nothing helped. If you could give any sort of advice of what I could try that would be greatly appreciated.
Sub KeepOnlyAtSymbolRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("E1:E" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*#*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
Do you specifically wish to refer to the sheet "Sheet1" in the currently open workbook?
If so, use the line below
Set ws = ActiveWorkbook.Worksheets("Sheet1")
And if you simply wish to refer to the current sheet, use
Set ws = ActiveSheet
And if you wish to simply target the first sheet, whatever its name,
Set ws = ActiveWorkbook.Worksheets(1)
The way the code is currently written, it seems to be referring to "Sheet1" in the personal workbook and not necessarily the one currently active with the user.