I'm new to VBA and am trying to design a program that will go through a column with Strings in it and for every unique String name create a new worksheet object with that String value as its name and then copy and paste the values in that row to the new sheet. All identical Strings should then also have the values in their row copied over to the new sheet. The data is not sorted based on the Strings so I might have String a, String b, String a, in a column and I want both String a's to be a part of the same new sheet. Before I added a few lines of code to account for this everything was working fine, but now I'm getting an application defined or object defined error at an if statement that shouldn't be related to the added code. Here it is:
Sub FilterByClass()
Dim i As Long
Dim j As Long
Dim sheetName As String
Dim sheet As Worksheet
Dim book As Workbook
Dim k As Integer
ActiveSheet.Name = "AllClasses"
sheetName = Worksheets("AllClasses").Cells(2, 1).Value
Worksheets.Add
ActiveSheet.Name = sheetName
Worksheets("AllClasses").Activate
ActiveSheet.Rows("1:2").Copy
Worksheets(sheetName).Paste
j = 3
k = 0
For i = 3 To Rows.Count
If Worksheets("AllClasses").Cells(i, 1).Value <> Worksheets("AllClasses").Cells(i - 1, 1).Value Then //site of error
Worksheets("AllClasses").Range("1:1," & j & ":" & (i - 1)).Copy
Worksheets(Worksheets("AllClasses").Cells((i - 1), 1).Value).Paste
j = i
sheetName = Worksheets("AllClasses").Cells(i, 1).Value
For Each sheet In ActiveWorkbook //new added code block
If sheetName = sheet.Name Then k = 1
Next sheet
If k = 1 Then k = 0
Else
Worksheets.Add
ActiveSheet.Name = sheetName
Worksheets("AllClasses").Activate
End If
Next i
End Sub
Any help would be greatly appreciated.
ΒΈ
I've noticed a few things wrong with your code that are easier to point out in an answer rather than a comment.
1. Code not valid --Ignore this--
You seem to be missing 2 End Ifs in the code you posted. I can only assume it's just a copy-paste error, so I'll swiftly move on.
2. Line with comment "new added code block"
Your code says:
For Each sheet In ActiveWorkbook
you should replace that with this:
For Each sheet In ActiveWorkbook.Worksheets
The Workbook is not a collection of sheets, the workbook's .Worksheets function is.
3. Termination of the outer For loop
In the comments, you said that the original error happens in the first iteration of your loop inside the If statement, but I'm not convinced. Having had a quick play with your code, I think the error you're seeing ('1004' : "Application-defined or object-defined error") is a result of a different problem.
In my run-through of your code, this line in the Else block of If k = 1:
ActiveSheet.Name = sheetName
caused the error. That is because this line:
sheetName = Worksheets("AllClasses").Cells(i, 1).Value
returned sheetName = "".
This situation happens when a cell in position Cells(i, 1) is empty, which is entirely possible in your code since your outer For loop is iterating over all rows in the "AllClasses" sheet -- all 1048576 of them (in Excel 2007 and later versions). Unless you've got a value in every single row's column 1 (which I doubt), then at some point you'll meet a cell that is blank. Assigning that blank string to ActiveSheet.Name will cause the error you're seeing.
You can either hardcode the value of your outer For loop's terminating condition or you can use the various "tricks" to dynamically determine that value, e.g. Sheet.UsedRange.Rows.Count or Sheet.Cells(1048576, col).End(xlUp).row.
Related
I'm working on a project and been playing around with VBA to reference a table of data and build Sheets with this info.
I can't put the real thing on here but I've built a variation with safe data in.
Basically my script works fine how I need it to, now I'm just keen to improve my knowledge a bit more on error checking as usually I just find the error and fix it. These 2 I have though i feel there is a more elegant way and I'm hoping someone here can help.
So the script references col C in a table, and creates new Sheets for it and renames them to the data found in the column.
At the end of the script I get a 1004 error, I know this is because the script got through all the data in the column and has nothing else to add. Is there a way to stop it sending up this error message please?
Also if I paritally ran the script, and got a couple of Sheets created. When I re-run it I get errors, as the Sheets are already made. Is there a way of telling the script that if it tries to name a Sheet with something that already exists then ignore it and move onto the next one?
I've uploaded a copy of the Excel sheet with the relevant code I'm on about along with some screenshots of each error.
I'll also post the code below after the sign-off.
Thanks in advance,
AM
Sub Addsheet()
Dim Row As Integer
Dim ColC As Integer
Dim i As Long
Row = 2
ColC = Worksheets("Member Data").Cells(Worksheets("Member Data").Rows.Count, "C").End(xlUp).Row
For i = 1 To ColC
Sheets.Add
ActiveSheet.Name = Worksheets("Member Data").Cells(Row, "C").Value
Row = Row + 1
Next i
End Sub
Error1
Error2
It doesn't make much sense to use an For i loop and then use another variable to increment Row = Row + 1, because i automatically increments on Next i. So just use that i if it is already there.
Another point is that you should use Long because Excel has more rows than Integer can handle. Also there is no benefit in using Integer at all in VBA, therefore we can recommend always to use Long instead of Integer.
For checking if a worksheet already exists I recommend to write a function (so we can re-use that code later if we need to).
Option Explicit
Public Sub Addsheet()
Dim LastRowC As Long 'use Long Excel has more rows than Integer can handle
LastRowC = Worksheets("Member Data").Cells(Worksheets("Member Data").Rows.Count, "C").End(xlUp).Row
Dim i As Long
For i = 2 To LastRowC 'loop from row 2 to last used row
Dim wsName As String
wsName = Worksheets("Member Data").Cells(i, "C").Value
'make sure the wsName cannot exceed 31 characters and doesn't include
'invalid characters for sheet names, or include an error handling here.
If WorksheetExists(wsName) = False Then 'call our function to check if sheet name already exists
Sheets.Add.Name = wsName 'add and rename the sheet
End If
Next i 'increment i+1 and do next loop
End Sub
Private Function WorksheetExists(wsName As String) As Boolean
WorksheetExists = False 'default
Dim i As Long
For i = 1 To ThisWorkbook.Worksheets.Count 'loop through all worksheets
If ThisWorkbook.Worksheets(i).Name = wsName Then 'check if name exists
WorksheetExists = True 'let the function return that it exists
Exit For 'we can stop searching when name was found
End If
Next i
End Function
To answer your second question, loop through the sheets and check if one with the name exists like:
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "MySheet" Then
exists = True
End If
Next i
If Not exists Then
Worksheets.Add.Name = "MySheet"
End If
Also, instead of using i as your counter, why not use Row, and remove the Row = Row + 1 This I believe should solve your first question.
I'm trying to create a macro that uses Index/match functions to match and pull data from one sheet into another. I did it in Excel and it works perfect. However the reports are "dynamic" (the size changes) so I need the last row of my code to be dynamic as well.
The following is what I have done. I'm NOW getting a "type mismatch" error (I emphasize "now" since every time I find a solution for one error another pop's up).
Dim prosheet As Worksheet
Dim prosheet2 As Worksheet
Set prosheet2 = ThisWorkbook.Sheets("shipstation")
Set prosheet = ThisWorkbook.Sheets("macrotestfb")
lr1 = prosheet.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = prosheet2.Cells(Rows.Count, 1).End(xlUp).Row
lrship = prosheet.Cells(Rows.Count, 10).End(xlUp).Row
lrindex = prosheet2.Cells(Rows.Column, 14).End(xlUp).Row
'CALCULATE SHIPPING COST
For x = prosheet.range("j6") To lrship
x = Application.WorksheetFunction.Index(prosheet2.range("a1:n" & lrindex), Application.WorksheetFunction.Match(prosheet.range("a6:a" & lr1), prosheet2.range("a1:a" & lr2), 0), prosheet2.range("f2"))
Next x
Match, in its non array form, only likes one value in the first criterion and not a range.
Also WorksheetFunction.Match will throw an error that will stop the code if a match is not found.
I like to pull the match into its own line and test for the error.
I also adjusted your For statement.
There is no detriment to searching an entire column so I got rid of a few of you last row searches as they are not needed.
Dim prosheet As Worksheet
Dim prosheet2 As Worksheet
Dim x As Long
Dim t As Long
Set prosheet2 = ThisWorkbook.Sheets("shipstation")
Set prosheet = ThisWorkbook.Sheets("macrotestfb")
lrship = prosheet.Cells(Rows.Count, 1).End(xlUp).Row
'CALCULATE SHIPPING COST
For x = 6 To lrship
t = 0
On Error Resume Next
t = Application.WorksheetFunction.Match(prosheet.Range("A" & x), prosheet2.Range("A:A"), 0)
On Error GoTo 0
If t > 0 Then
prosheet.Cells(x, "J").Value = prosheet2.Range("F"&t)
Else
prosheet.Cells(x, "J").Value = "Item does not Exist"
End If
Next x
Note:
Instead of an Index/Match combo which you might use on the worksheet, you can use Application.Match in VBA. Something like this:
Sub GetMatch
Dim indexRng As Range, matchRng as Range
Set indexRng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A10")
Set matchRng = ThisWorkbook.Worksheets("Sheet1").Range("B1:B10")
debug.print indexRng.Cells(Application.Match("something",matchRng,0)).Value
End Sub
Ok, this might take a bit to explain. I have a single MS Excel setting log sheet for a machine in our plant that contains setting specs for over 100 different part numbers built on that machine (each row is a different part number). We're switching to a new format that will have a separate sheet for each part number, with each sheet following a certain format (I set up a template beforehand and copied it for each part number). The first column of the old log sheet contains all of the part numbers, and the sheet names correspond to these part numbers.
So I'm trying to set up a program that will repeat for each part number (each sheet), and will find that number in the first column of the old log sheet. Then it will pull the value from the cell in, let's say, column B of that row, and will place that value in a specific cell in the sheet for that part number. Now, this will need to pull data from several cells for each part number, but if I can get it to work for one, I can go from there.
Here's what I've got so far:
Sub EditSettings()
Dim i As Integer
Dim j As Integer
Dim lastrow As Integer
lastrow = Sheets("M200 46mm Setting Log").Range("A" & Rows.Count).End(xlUp).Row
For i = 5 To Worksheets.Count
For j = 4 To lastrow
If Sheets("M200 46mm Setting Log").Cells(j, "A").Value = "" Then
ElseIf Sheets("M200 46mm Setting Log").Cells(j, "A").Value = Sheets(i).Name Then
Sheets("M200 46mm Setting Log").Range(j, "B").Copy _
Destination:=Sheets(i).Range("D11")
End If
Next
Next
End Sub
When I run this however, it gives me an error saying "Run-time error '1004': Application-defined or object-defined error".
This is easier than you might imagine. You don't need to loop through each of the worksheets because you can assign the target worksheet by its name: Set ws = WorkSheets([name as a string]). So you really only need to loop through the rows and pick up each sheet name.
I'd also recommend creating an address map of each old sheet cell and its new sheet cell address. In your example, column "B" goes to "D11", so create a collection of all of these and simply loop through them for the copying. There are quicker ways of doing it but with only 100 or so different parts it's not worth worrying about.
The code below shows you how to do both. From your question you mention that you have created templates for each new sheet. Presumably, then, the format is correctly set, so you've no need to do a copy/paste, just write each cell value to the new cell.
By the way, the most obvious error in your code (and probably the reason for your error) is that this line: Sheets("M200 46mm Setting Log").Range(j, "B").Copy ... should be Sheets("M200 46mm Setting Log").Cells(j, "B").Copy ...
Sub RunMe()
Dim wsLog As Worksheet
Dim wsPart As Worksheet
Dim sheetName As String
Dim addressMap As Collection
Dim map As Variant
Dim lastRow As Long
Dim r As Long
Set addressMap = New Collection
' Map the transfer cell addresses
addressMap.Add SetRangeMap("B", "D11")
' 1st item is old log sheet column, 2nd is address of new sheet
' ...
' ... repeat for all the address maps
' ...
'Loop through the rows in the source sheet
Set wsLog = ThisWorkbook.Worksheets("M200 46mm Setting Log")
lastRow = wsLog.Cells(wsLog.Rows.Count, "A").End(xlUp).Row
For r = 4 To lastRow
' Acquire the sheet name from the part number cell
sheetName = CStr(wsLog.Cells(r, "A").Value2)
' Try to assign the parts number worksheet
Set wsPart = Nothing
On Error Resume Next
Set wsPart = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
' If assigment worked then transfer data
If Not wsPart Is Nothing Then
For Each map In addressMap
wsPart.Range(map(1)).Value = wsLog.Cells(r, map(0)).Value2
Next
End If
Next
End Sub
Private Function SetRangeMap(sourceCol As String, partAddress As String) As Variant
Dim map(1) As String
map(0) = sourceCol
map(1) = partAddress
SetRangeMap = map
End Function
I require the searching functionality in Excel Macro.
Scenario:
Step 1) Excel1.xlsx have one column as primary key which I have to find in the Excel2.xlsx
Step 2) If the matching is found in the above step, then have to take a value of another column in Excel2.xlsx (from the same row which match the step 1) and fill in the Excel1.xlsx.
Is there any VBA macro to solve this issue?
PREFACE: As noted in the commentary by #L42, functions like VLOOKUP are a simpler solution, depending on the project size and need to be dynamic. That having been said, assuming you have a NEED for VBA, as your question is tagged, I have provided this code.
Without knowing the columns you are trying to use, I have provided an example scenario. I am SURE you can streamline this more by omitting some of the variables. I have included them to allow for the names to be set more easily with minimal modifications. Feel free to reduce the amount of variables needed once you understand the concepts behind them of you desire.
In the example, I'm using Column A for the lookup value and Column D as the value to be copied to the other sheet IF the conditions are met. The Name and Date are irrelevant data just to give context. A & D are the only columns being scanned, or used.
WARNING: THE FOLLOWING LINE CAN CAUSE PROBLEMS IF YOU ENCOUNTER AN INFINITE LOOP. If you encounter an infinite loop, the normal break mode will not work. If you don't want that to be included, it's not a problem, comment out this line and you will be prompted with a BREAK when the second workbook opens. Just hit continue.
Look carefully at the naming of the sheets. You will need to input your own values.
Application.EnableCancelKey = xlDisabled 'Disables breaking when opening new book
TESTED:
Sub UpdateExternalBook()
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim path As String
Dim s2Name As String, s1SheetName As String, s2SheetName As String
Dim lookupVal As String, moveVal As String
Dim lastS1Row As Long, lastS2Row As Long
'CONFIGURE TO YOUR FILE PATHS HERE
path = "YOUR FILE PATH HERE" '"C:\Users\Owner\Documents\"
s2Name = "SECOND BOOK NAME WITH EXTENSION" '"Book1.xlsm" or "Book1.xlsx"
'Name your Sheets here.
s1SheetName = "MASTER" 'SOURCE BOOK SHEET NAME
s2SheetName = "Sheet1" 'SECOND BOOK SHEET NAME
Application.EnableCancelKey = xlDisabled 'Disables breaking when opening new book
Set s1Sheet = ThisWorkbook.Sheets(s1SheetName)
Set s2Sheet = Workbooks.Open(path & s2Name).Sheets(s2SheetName)
lastS1Row = s1Sheet.Range("A" & Rows.count).End(xlUp).row
lastS2Row = s2Sheet.Range("A" & Rows.count).End(xlUp).row
'BEGIN LOOPING THROUGH ORIGINAL SHEET
For lRow = 2 To lastS1Row
lookupVal = s1Sheet.Cells(lRow, "A") 'Lookup Value in Column "A"
moveVal = s1Sheet.Cells(lRow, "D") 'Value to Copy to second book
For tRow = 2 To lastS2Row
If s2Sheet.Cells(tRow, "A") = lookupVal Then
s2Sheet.Cells(tRow, "D") = moveVal 'Copy data from source to target
End If
Next tRow
Next lRow
'WRAP UP AND CLOSE SECOND WORKBOOK
'Activate and close the second workbook
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
End Sub
Original Sheet:
Target BEFORE ---> AFTER:
Yes you can, first use below DataPreparation in goal to create dataset, data in column A is your Excel1 dataset, columns B and C are your Excel2 dataset, column D contain solution. My solution works on single Excel file as described above, it uses Excel's vlookup function.
Sub DataPreparation()
Range("A1:A5") = Application.WorksheetFunction.Transpose(Array("a", "b", "c", "d", "e"))
Range("B1:B5") = Application.WorksheetFunction.Transpose(Array("c", "d", "a", "a", "f"))
Range("C1:C5") = Application.WorksheetFunction.Transpose(Array(3, 4, 1, 1, 6))
End Sub
Sub vLookupMacro()
On Error Resume Next
Dim r1 As Range
Dim r2 As Range
Dim rOutput As Range
Set r1 = Range("A1:A5")
Set r2 = Range("B1:C5")
Set rOutput = Range("D1:D5")
For Each x In rOutput
x.Value = Application.WorksheetFunction.VLookup(r1.Cells(x.Row, 1), r2, 2, 0)
Next x
End Sub
As new user please take the tour :
https://stackoverflow.com/tour
I'm new to VBA and am trying to design a program that will go through a column with Strings in it and for every unique String name create a new worksheet object with that String value as its name and then copy and paste the values in that row to the new sheet. All identical Strings should then also have the values in their row copied over to the new sheet. I'm not even sure if the program itself works, but before I can check I keep getting an error that I haven't been able to fix.
The error is run time error '9' subscript out of range.
The thing is the new sheet is getting created but is not getting filled up with any data. It's as if the program goes straight to the else statement and then finds an error that I'm not sure how to fix even though it should be going through the If statement at least once because I know that the String in A3 is the same as that in A2. Here's the full code:
Sub FilterByClass()
Dim i As Long
Dim j As Long
Dim sheetName As String
ActiveSheet.Name = "AllClasses"
sheetName = Worksheets("AllClasses").Cells(2, 1).Value
Worksheets.Add
ActiveSheet.Name = sheetName
Worksheets("AllClasses").Activate
Worksheets(sheetName).Rows(1) = ActiveSheet.Rows(1)
Worksheets(sheetName).Rows(2) = ActiveSheet.Rows(2)
j = 3
For i = 3 To Rows.Count
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Worksheets(Cells(i, 1).Value).Rows(j) = ActiveSheet.Rows(i)
j = j + 1
Else
Worksheets.Add
ActiveSheet.Name = ThisWorkbook.Sheets(sheetName).Cells(i, 1).Value
Worksheets("AllClasses").Activate
j = 1
Worksheets(Cells(i, 1).Value).Rows(j) = ActiveSheet.Rows(1)
j = j + 1
Worksheets(Cells(i, 1).Value).Rows(j) = ActiveSheet.Rows(i)
End If
Next i
End Sub
Any help would be appreciated. And if you see anything in the rest of the code that looks like it clearly won't work as intended please point it out as well. Thanks
Before you name a worksheet, check if the sheet exists like David mentioned in the comments.
Here is my favorite way of checking if the sheet exists
Sub Sample()
If DoesSheetExist("AllClasses") Then
MsgBox "Sheet Already Exists"
Else
ActiveSheet.Name = "AllClasses"
End If
End Sub
Function DoesSheetExist(Sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(Sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
Also if the sheet doesn't exist then it may be possible that the workbook is protected. To check if that is the case, you can use the below code
If ThisWorkbook.ProtectStructure = True Then
MsgBox "Workbook structure is protected"
Else
MsgBox "Workbook structure is not protected"
End If