VBA Double FOR loop with an IF statement - excel

I need a VBA script that will perform a double FOR loop. The first FOR loop, is a loop that needs to perform a few commands over multiple sheets (The first sheet is the main sheet and needs to be skipped!!)
The second for loop needs to compare values on multiple rows. I have pasted my code so far...
Public Sub LoopOverSheets()
device = Cells(6, 1) 'This value is whatever the user chooses from a drop-down menu
Dim mySheet As Worksheet 'Creating variable for worksheet
orow = 8 'setting the starting output row
For Each mySheet In ThisWorkbook.Sheets 'this is the first FOR loop, to loop through ALL the worksheets
tabName = ActiveSheet.Name 'this is a variable that holds the name of the active sheet
For irow = 2 To 10 'This line of code starts the SECOND FOR loop.
If (Range("a" & irow)) = device Then 'This line of code compares values
orow = orow + 1
Range("'SUMMARY'!a" & orow) = device 'This line of code pastes the value of device variable
Range("'SUMMARY'!b" & orow) = tabName 'This line of code needs to paste the name of the current active sheet
'Range("'SUMMARY'!c" & orow) = Range("'tabName'!b" & irow) 'this line of code needs to paste whatever value is in the other sheet's cell
'Range("'SUMMARY'!d" & orow) = Range("'tabName'!c" & irow) 'same objective as the last line of code, different rows and columns
End If
Next irow 'This line of code will iterate to the next orow. This is where I get an error (Compile Error : Next Without For)*******
Next mySheet 'This line of code will iterate to the next sheet
End Sub
Currently the code runs, but it is only outputting results from the first (main sheet). It needs to skip the first sheet and iterate through the rest of them.

Update Summary Worksheet
Link: StrComp Function
The following is not tested.
The Code
Option Explicit
Sub loopOverSheets()
Const tName As String = "Summary"
Const tFirstRow As Long = 8
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim tgt As Worksheet
Set tgt = wb.Worksheets(tName)
Dim device As String
device = tgt.Cells(6, 1).Value
Dim tRow As Long
tRow = tFirstRow
Dim src As Worksheet
Dim sName As String
Dim i As Long
For Each src In wb.Worksheets
sName = src.Name
If Not StrComp(sName, tName, vbTextCompare) = 0 Then
For i = 2 To 10
If StrComp(src.Range("A" & i), device, vbTextCompare) = 0 Then
tRow = tRow + 1
tgt.Range("A" & tRow).Value = device
tgt.Range("B" & tRow).Value = sName
tgt.Range("C" & tRow).Value = src.Range("B" & i).Value
tgt.Range("D" & tRow).Value = src.Range("C" & i).Value
End If
Next i
End If
Next src
MsgBox "Data transferred.", vbInformation, "Success"
End Sub

Dim irow As Long
Dim ws As Worksheet
Dim mySheet As String
mySheet = "mainSheet" 'Insert in the mySheet variable the name of your main sheet
device = Cells(6, 1)
orow = 8
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name <> mySheet Then
For irow = 2 To 10
If ws.Range("A" & irow) = device Then
orow = orow + 1
Range("'SUMMARY'!a" & orow) = device
Range("'SUMMARY'!b" & orow) = ws.Name
'Range("'SUMMARY'!c" & orow) = Range("'tabName'!b" & irow) 'this line of code needs to paste whatever value is in the other sheet's cell
'Range("'SUMMARY'!d" & orow) = Range("'tabName'!c" & irow) 'same objective as the last line of code, different rows and columns
End If
Next irow
End If
Next ws

Related

Obtain a list of information Pertaining to a Specific Month

I have trouble running this script to obtain Summary information for a specific month. I am explaining below the details of my workbook.
Tab 1 called "Schedule"
Tab 2 called "Results"
Tab 3 called "Sheet3"
I would like to obtain info from column C (Summary) in tab1 for the month of July. I am entering the month in tab2 and would like to run the macro and obtain all the results pertaining to the month of July.
Sub schedule()
Dim sch As Workbook
Dim schTot As Worksheet
Dim schRes As Worksheet
Dim i As Long
Dim j As Long
Let sch = Thisworkbook
Let schRes = sch.Worksheets("Results")
Let schTot = sch.Worksheets("Schedule")
For i = 1 To schTot.Range("A1").End(xlDown)
For j = 3 To schRes.Range("B3").End(xlDown)
If schTot.Cells(i, 1).Value = schRes.Cells(1, 2).Value Then
If schRes.Cells(j, 1).Value = "" Then
schTot.Rows(i).Copy
schRes.Cells(j, 1).Paste
Application.CutCopyMode = False
'Exit For
End If
End If
Next j
Next i
End Sub
Try this:
Option Explicit
Sub schedule()
Dim sch As Workbook
Dim schTot As Worksheet
Dim schRes As Worksheet
Dim i As Long
Dim j As Long
Dim strMonth As String
With ThisWorkbook
Set schRes = .Worksheets("Results")
Set schTot = .Worksheets("Schedule")
End With
schRes.Range("A3:C" & schRes.Cells(3, 1).End(xlDown).Row).ClearContents
strMonth = schRes.Cells(1, 2).Value
i = 2
j = 3
With schTot
Do Until .Cells(i, 1).Value = ""
If .Cells(i, 1).Value = strMonth Then
schRes.Range("A" & j & ":C" & j).Value = .Range("A" & i & ":C" & i).Value
j = j + 1
End If
i = i + 1
Loop
End With
End Sub
For your code, you just need to change following things to get it run:
-use "Set" instead of "Let"
Set sch = Thisworkbook
Set schRes = sch.Worksheets("Results")
Set schTot = sch.Worksheets("Schedule")
-return row's number in for loop condition
For i = 1 To schTot.Range("A1").End(xlDown).Row
For j = 3 To schRes.Range("B3").End(xlDown).Row
Then your code will be ok to run, but if your B3 cell in Results worksheet don't have value or following cells(i.e. B4,B5,B6...) doesn't have vale, your code will run infinitely and crush eventually.
Also, you copy a entire row in loop every single time which contain unnecessary cells. This will horribly slow down your code.
To speed up the code, I recommend to use auto filter to solve the problem:
Sub sechedule()
Dim sch As Workbook: Set sch = ThisWorkbook
Dim schTot As Worksheet: Set scTot = sch.Worksheets("Schedule")
Dim schRes As Worksheet: Set schRes = sch.Worksheets("Results")
Dim month As String
month = Range("B1").Value 'The month you inputted in Results worksheet
'I suppose you want to paste the result to Results worksheet starting from Cell A3, so the contents will be cleared first each time if somethings are in the result area:
If Range("A3").Value = "" Then Range("A3:C" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
With schTot
.Activate
.Range("A:C").AutoFilter Field:=1, Criterial:=month 'Choose data for specific month with auto filter
.Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=schRes.Range("A3") '<--You can change the paste destination here
.ShowAllData
.Range("A:C").AutoFilter 'Cancel auto filter
End With
schRes.Activate
End Sub

Excel file crashes and closes when I run the code, but results of the code who when I reopen the file

I am copying data under columns with matching headers between the source sheet and the destination sheet. Both the sheets are in the same excel file but they need to have a clarification number.
For example, one of the columns in the destination sheet has the the clarification number QM6754 and the row of data of QM6754. The source sheet also has the clarification number column but I dont want to copy it, I want to copy the other data in the row of this specific clarification number to the destination sheet that in one of its columns. this way the data isn't copied randomly and the entire row from each sheet relate to each other.
The code I used shows results(I modified it) but when I run it, the excel file shows (not responding) for about 3-4 minutes and then shutsdown or leaves a blank Excel sheet and VBA window. I close the excel file and reopen it and the data has been copied. The file is quite large and I have three pushbuttons that run this code for each sheet I want to copy data from. Three sheets with average of 3k-6k rows. But I cannot eliminate the rows.
The code runs but I would like to optimize of the way it runs because it isn't practical to run, close file and then open file again. Could the issue be with the For loop?
Sub CopyColumnData()
Dim wb As Workbook
Dim myworksheet As Variant
Dim workbookname As String
' DECLARE VARIABLES
Dim i As Integer ' Counter
Dim j As Integer ' Counter
Dim colsSrc As Integer ' PR Report: Source worksheet columns
Dim colsDest As Integer ' Open PR Data: Destination worksheet columns
Dim rowsSrc As Long ' Source worksheet rows
Dim WsSrc As Worksheet ' Source worksheet
Dim WsDest As Worksheet ' Destination worksheet
Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
Dim searchKey As String, foundKey As String
workbookname = ActiveWorkbook.Name
Set wb = ThisWorkbook
myworksheet = "Sheet 1 copied Data"
wb.Worksheets(myworksheet).Activate
' SET VARIABLES
' Source worksheet: Previous Report
Set WsSrc = wb.Worksheets(myworksheet)
Workbooks(workbookname).Sheets("Main Sheet").Activate
' Destination worksheet: Master Sheet
Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
'Adjust incase of change in column in both sheets
ws1ORNum = "K" 'Clarification Number
ws2ORNum = "K" 'Clarification Number
' Setting first and last row for the columns in both sheets
ws1PRRow = 3 'The row we want to start processing first
ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
ws2PRRow = 3 'The row we want to start search first
ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
For i = ws1PRRow To ws1EndRow ' first and last row
searchKey = WsSrc.Range(ws1ORNum & i)
'if we have a non blank search term then iterate through possible matches
If (searchKey <> "") Then
For j = ws2PRRow To ws2EndRow ' first and last row
foundKey = WsDest.Range(ws2ORNum & j)
' Copy result if there is a match between PR number and line in both sheets
If (searchKey = foundKey) Then
' Copying data where the rows match
WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
Exit For
End If
Next
End If
Next
'Close Initial PR Report file
wb.Save
wb.Close
'Pushbuttons are placed in Summary sheet
'position to Instruction worksheet
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
End Sub
To increase the speed and reliability, you will want to handle the copy/paste via array transfer instead of the Range.Copy method. Given your existing code, here's how a solution that should work for you:
Sub CopyColumnData()
'Source data info
Const sSrcSheet As String = "Sheet 1 copied Data"
Const sSrcClarCol As String = "K"
Const lSrcPRRow As Long = 3
'Destination data info
Const sDstSheet As String = "Main Sheet"
Const sDstClarCol As String = "K"
Const lDstPRRow As Long = 3
'Set variables based on source and destination
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets(sSrcSheet)
Dim wbDst As Workbook: Set wbDst = ActiveWorkbook
Dim wsDst As Worksheet: Set wsDst = wbDst.Worksheets(sDstSheet)
On Error GoTo 0
'Verify source and destination were found
If wsSrc Is Nothing Then
MsgBox "Worksheet """ & sSrcSheet & """ not found in " & wbSrc.Name
Exit Sub
End If
If wsDst Is Nothing Then
MsgBox "Worksheet """ & sDstSheet & """ not found in " & wbDst.Name
Exit Sub
End If
'Setup variables to handle Clarification Number matching and data transfer via array
Dim hDstClarNums As Object: Set hDstClarNums = CreateObject("Scripting.Dictionary") 'Clarification Number Matching
'Load Source data into array
Dim rSrcData As Range: Set rSrcData = wsSrc.Range(sSrcClarCol & lSrcPRRow, wsSrc.Cells(wsSrc.Rows.Count, sSrcClarCol).End(xlUp))
Dim aSrcClarNums() As Variant: aSrcClarNums = rSrcData.Value
Dim aSrcData() As Variant: aSrcData = Intersect(rSrcData.EntireRow, wsSrc.Columns("A:H")).Value 'Transfer data from columns A:H
'Prepare dest data array
Dim rDstData As Range: Set rDstData = wsDst.Range(sDstClarCol & lDstPRRow, wsDst.Cells(wsDst.Rows.Count, sDstClarCol).End(xlUp))
Dim aDstClarNums() As Variant: aDstClarNums = rDstData.Value
Dim aDstData() As Variant: aDstData = Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value 'Destination will be into columns AI:AP
'Use dictionary to perform Clarification Number matching
Dim vClarNum As Variant
For Each vClarNum In aDstClarNums
If Not hDstClarNums.Exists(vClarNum) Then hDstClarNums.Add vClarNum, hDstClarNums.Count + 1
Next vClarNum
'Transfer data from source to destination using arrays
Dim i As Long, j As Long
For i = 1 To UBound(aSrcClarNums, 1)
For j = 1 To UBound(aSrcData, 2)
If hDstClarNums.Exists(aSrcClarNums(i, 1)) Then aDstData(hDstClarNums(aSrcClarNums(i, 1)), j) = aSrcData(i, j)
Next j
Next i
'Output to destination
Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value = aDstData
'Save and close source workbook (uncomment next line if this is necessary)
'wbSrc.Close SaveChanges:=True
'Activate summary sheet, cell A1 in destination workbook (uncomment these lines if this is necessary)
'wbDst.Worksheets("Summary").Activate
'wbDst.Worksheets("Summary").Range("A1").Select
End Sub

Excel Auto Change Sheet Name Based On Cells VBA

We have a workbook that needed to have the sheets change names every month and I decided to automate it for other employees. So after some research I found the best way to do it was to reference the names of cells. I needed it to start running on the 4th sheet and run through the second last sheet. I found some VBA code and edited it until I got to this point:
Sub RenameSheet()
Dim ShCnt As Integer 'count of sheets in workbook
Dim myarray() As String 'array of new worksheet names
Dim Month() As String 'mystery variable -- not used in this code
Dim i As Integer 'loop counter
Dim Lrow As Integer 'number of new worksheet names.
ThisWorkbook.Sheets("SETUP").Select 'select the sheet that has the list of new names
Lrow = Range("T1").End(xlDown).Row 'get range that contains new worksheet names
ShCnt = ThisWorkbook.Sheets.Count 'get number of worksheets in the workbook
ReDim myarray(1 To Lrow) 'resize array to match the number of new worksheet names
For i = 1 To UBound(myarray) 'loop through array of new sheet names
myarray(i) = Range("T" & i).Value 'insert new sheet name into array
Debug.Print Range("T" & i).Value 'show the new worksheet name in 'the Immediate window to be able to check that we're getting what we want
Next i 'end of loop
For i = 4 To ShCnt - 1 'loop through array of existing worksheets
Sheets(i).Name = myarray(i) 'rename each worksheet with the matching name from myarray
Next i 'end of loop
MsgBox "Sheets name has changed successfully" 'report success
End Sub
My issue is that I need the 4th sheet to start with the value in cell "T2". I have figured out that this section of code changed the starting point:
For i = 1 To UBound(myarray)
myarray(i) = Range("T" & i).Value
Debug.Print Range("T" & i).Value
Next i
When I replaced myarray(i) = Range("T" & i).Value with myarray(i) = Range("T2" & i).Value it started on cell T24 for some reason (which may have to do with the placement of my button?) and myarray(i) = Range("T" + 1 & i).Value doesn't work.
I also tried changing the For i = 1 To UBound(myarray) to For i = 2 To UBound(myarray) and that didn't work either.
Can someone please help me figure out how to get it so that the information in cell T2 ends up on the 4th sheet and goes from there? Thank you very much in advance.
I would suggest loop through worksheets in the workbook and use the loop counter to index into the range of names in column T:
Sub RenameSheet()
Dim ShCnt As Integer
Dim i As Integer
Dim ws_setup As Worksheet
Set ws_setup = ThisWorkbook.Worksheets("SETUP")
ShCnt = ThisWorkbook.Worksheets.Count
Const start_ws_index = 4
For i = start_ws_index To ShCnt - 1
ThisWorkbook.Worksheets(i).Name = _
ws_setup.Range("t2").Offset(i - start_ws_index, 0).Value
Next i
End Sub
Rename Sheets From List
In the current setup, it is assumed that the list is contiguous (no blanks), has at least two entries, and starts in cell T2, and that the 4th sheet is the first to be renamed.
The Code
Option Explicit
Sub renameSheets()
' Constants
Const wsName As String = "SETUP"
Const FirstCell As String = "T2"
Const FirstSheetIndex As Long = 4
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Array (at least two names)
Dim SheetNames As Variant
With wb.Worksheets(wsName)
SheetNames = .Range(FirstCell, .Range(FirstCell).End(xlDown))
End With
' Rename
Dim shOffset As Long: shOffset = FirstSheetIndex - 1
Dim i As Long
For i = 1 To UBound(SheetNames, 1)
wb.Sheets(i + shOffset).Name = SheetNames(i, 1)
Next i
' Inform
MsgBox "Sheet names changed successfully", vbInformation
End Sub

Excel macro to create new sheet every n-rows

I'm attempting to write a macro to take an excel file of several thousand rows and split the inital sheet's rows up into sheets of 250 rows per-sheet, not including the original header row, which should also be copied to each sheet. There are 13 columns total, and some of the fields are empty.
I can sort the document myself - that's not an issue - I just don't have the macro skill to figure this one out.
I've tried searching, and found a few examples, but none quite fit..such as this one..
create macro that will convert excel rows from single sheet to new sheets ..or this one.. Save data input from one sheet onto successive rows in another sheet
Any help?
This should provide the solution you are looking for as well. You actually added your answer as I was typing it, but maybe someone will find it useful.
This method only requires that you enter the number of rows to copy to each page, and assumes you are on the "main" page once you execute it.
Sub AddSheets()
Application.EnableEvents = False
Dim wsMasterSheet As Excel.Worksheet
Dim wb As Excel.Workbook
Dim sheetCount As Integer
Dim rowCount As Integer
Dim rowsPerSheet As Integer
Set wsMasterSheet = ActiveSheet
Set wb = ActiveWorkbook
rowsPerSheet = 5
rowCount = Application.CountA(Sheets(1).Range("A:A"))
sheetCount = Round(rowCount / rowsPerSheet, 0)
Dim i As Integer
For i = 1 To sheetCount - 1 Step 1
With wb
'Add new sheet
.Sheets.Add after:=.Sheets(.Sheets.Count)
wsMasterSheet.Range("A1:M1").EntireRow.Copy Destination:=Sheets(.Sheets.Count).Range("A1").End(xlUp)
wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Cut Destination:=Sheets(.Sheets.Count).Range("A" & Rows.Count).End(xlUp).Offset(1)
wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Delete
ActiveSheet.Name = "Rows " + CStr(((.Sheets.Count - 1) * rowsPerSheet + 1)) & " - " & CStr((.Sheets.Count * rowsPerSheet))
End With
Next
wsMasterSheet.Name = "Rows 1 - " & rowsPerSheet
Application.EnableEvents = True
End Sub
#pnuts's suggested solution by Jerry Beaucaire worked perfectly.
https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows
Option Explicit
Sub SplitDataNrows()
'Jerry Beaucaire, 2/28/2012
'Split a data sheet by a variable number or rows per sheet, optional titles
Dim N As Long, rw As Long, LR As Long, Titles As Boolean
If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _
"Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False
With ActiveSheet
LR = .Range("A" & .Rows.Count).End(xlUp).Row
For rw = 1 + ---Titles To LR Step N
Sheets.Add
If Titles Then
.Rows(1).Copy Range("A1")
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
Else
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
End If
Columns.AutoFit
Next rw
.Activate
End With
Application.ScreenUpdating = True
End Sub
--
Option Explicit
Sub SplitWorkbooksByNrows()
'Jerry Beaucaire, 2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range
srcPATH = "C:\Path\To\Source\Files\" 'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\" 'remember the final \ in this string
'determine how many rows per sheet to create
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub 'exit if user clicks CANCEL
'Examples of usable ranges: A:A A:Z C:E F:F
Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
If Cols = "False" Then Exit Sub 'exit if user clicks CANCEL
'prompt to repeat row1 titles on each created sheet
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False 'speed up macro execution
Application.DisplayAlerts = False 'turn off system alert messages, use default answers
fNAME = Dir(srcPATH & "*.xlsx") 'get first filename from srcPATH
Do While Len(fNAME) > 0 'exit loop when no more files found
Set wbDATA = Workbooks.Open(srcPATH & fNAME) 'open found file
With ActiveSheet
LR = Intersect(.Range(Cols), .UsedRange).Rows.Count 'how many rows of data?
If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
Cnt = Cnt + 1 'increment the sheet creation counter
Sheets.Add 'create the new sheet
If Titles Then titleRNG.Copy Range("A1") 'optionally add the titles
'copy N rows of data to new sheet
Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
ActiveSheet.Columns.AutoFit 'cleanup
ActiveSheet.Move 'move created sheet to new workbook
'save with incremented filename in the destPATH
ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
ActiveWorkbook.Close False 'close the created workbook
Next rw 'repeat with next set of rows
End With
wbDATA.Close False 'close source data workbook
fNAME = Dir 'get next filename from the srcPATH
Loop 'repeat for each found file
Application.ScreenUpdating = True 'return to normal speed
MsgBox "A total of " & Cnt & " data files were created." 'report
End Sub

Excel 2007 VBA runtime error when selecting worksheet with variable

I've been recently getting back into VBA and have been testing out a concept of Adding Worksheets by the string in a variable. I've been able to get the worksheets to add successfully and the last two lines of my code are simply to select the sheet name of the variable and then select cell A + the row number that is stored in another variable
In Sheet1, Column A, starting in A1, I have a list of 8 different names that cycles through:
Bob
Jeff
Max
Steve
Rosie
Pippa
Penelope
Rob
I am expecting the macro to end on Sheet "Rob" with cell A9 selected, however i get a runtime 1004 error
I have stepped through the code and it is selecting the sheet correctly with the variable, but when it tries to select row A9, the error presents
My code is below:
Sub Add_worksheets()
Dim sheetName As String
Dim rownum As Integer
rownum = 1
Range("A" & rownum).Select
sheetName = ActiveCell.Value
Do Until Range("A" & rownum).Value = ""
Range("A" & rownum).Select
sheetName = CStr(ActiveCell.Value)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
Sheets("sheet1").Select
rownum = rownum + 1
Loop
Sheets(sheetName).Select
Range("A" & rownum).Select
End Sub
Any help would be greatly appreciated
I also suggest you add if-else to check if the sheet name exists.. Why do you want to select? I do not support selections, since you need it you may try this: Because when you are incrementing rownum it goes to 10th cell, that means, Sheetname no longer has a name but empty..
Dim sheetName As String
Dim rownum As Integer
Dim WS as WorkSheet
rownum = 1
sheetName = Range("A" & rownum).Value '-- remove select
Do Until Range("A" & rownum).Value = ""
Range("A" & rownum).Select
sheetName = CStr(ActiveCell.Value)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
Set WS = Sheets(sheetName)
Sheets("sheet1").Select
rownum = rownum + 1
Loop
rownum = rownum - 1 '-- here
WS.Activate
Range("A" & rownum).Value = rownum
Or you may just use an array to do the creation of the sheets and then select a sheet later....Instead of going back and forth to first sheet...with names..
Sub addSheets()
Dim rowNum as Integer
Dim Ws as WorkSheet
Dim vArray as Variant
'-- creates one dimensional array
vArray = WorkSheetFunction.Transpoe(Sheets(1).Range("A1:A9"))
For rownum = Lbound(vArray) to Ubound(vArray)
If IsEmpty(vArray(rowNum)) Then
On Error Resume Next
Set Ws = Sheets(vArray(rowNum))
If Err.Number <> 0 Then '--no such sheet, so add it
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = vArray(rowNum)
Set Ws = Sheets(vArray(rowNum))
End If
End IF
Next rownum
Ws.Activate
Ws.Range("A1").offset(rownum).value = rownum
End Sub

Resources