Add sheets and rename in loop - excel

I have a "template" sheet that I copy in a loop (number of values in a column in another sheet) and then I use that value in the column to rename the sheet.
I unhide the template sheet, copy after, and then rename the sheet using the Index plus the loop index i.
This approach is dependent on the template sheet always being in the same location, so the other sheets can be inserted after and the index is correct.
I'd like, on each iteration of the loop, the copied sheet added as the last sheet and then renamed, so that it is not dependent on the "template" index value (in case a user inserts a sheet after the "template").
Sub AddMultipleSheet2()
Dim sheets_count As Integer
Dim sheet_name As String
Dim i As Integer
Worksheets("Template").Visible = True
sheet_count = Range("B12:B61").Rows.Count
For i = 1 To sheet_count
sheet_name = Sheets("Test setup").Range("B12:B61").Cells(i, 1).Value
If SheetCheck(sheet_name) = False And sheet_name <> "" Then
'Copy sheet
Set ws = Sheets("FAR 1")
ws.Copy After:=Sheets(Sheets.Count)
'Rename sheet (name of test step)
Set wsNew = Sheets(Sheets("Template").Index + i)
wsNew.Name = sheet_name
'Set value in new sheet
Set myCellSetValue = ThisWorkbook.Worksheets(sheet_name).Range("A1")
'set cell value with Range.Value property
myCellSetValue.Value = sheet_name
End If
Next i
Worksheets("Template").Visible = False
End Sub

You put the copy after the last sheet, so you can pick it up from there:
Set wsNew = Sheets(Sheets.Count)

Related

Iterating through a column, creating new worksheet based on cell VBA

Want to iterate through column first checking if name in the excel exists as a worksheet, if not then create a worksheet with that name, but existing code does not work.
Sub genWorksheet()
' for loop to iterate through column b
' get name from column b and store name n variable
' checks if a worksheet with the name in the cell exists
' if not, then it will create a new worksheet
Dim myRow As Integer
Dim categoryName As String
Dim sht As Worksheet
Dim shtName As String
Dim found As Boolean
myRow = 4
Do While Cells(myRow, 1) <> ""
myRow = myRow + 1
categoryName = Range("B" & myRow) 'Set variable equal to the category name
For Each sht In ThisWorkbook.Worksheets 'For each sheet in the workbook
found = False ' set found = false
If sht.name = categoryName Then ' check if the sheet name equals too category name
found = True ' if it does then set found equal to true
End If
If found = True Then ' break out of the loop since we did find a match
Exit For
End If
Next sht
If found = False Then ' if no match was foundthen add the new sheet
Sheets.Add.name = categoryName
End If
Loop
End Sub
Here is the excel data if needed:
Picture of the excel data
There are two issues with your code.
Firstly, you increment MyRow immediately after testing, not at the end of the iteration. The increment needs to go at the end of your loop.
Secondly, you haven't specified in your code which worksheet column B is on. This is probably fine when you start the loop, but once a worksheet is found to be missing, it creates the worksheet and thereafter starts looking at that worksheets column B - which will be empty and cause the loop to stop.
I have a shorter way to test if a worksheet exists - which removes the need for the inner loop. Here is my revised version of your code which I believe will suit your purposes:
Sub genWorksheet()
' for loop to iterate through column b
' get name from column b and store name n variable
' checks if a worksheet with the name in the cell exists
' if not, then it will create a new worksheet
Dim myRow As Long
Dim categoryName As String
With ActiveSheet ' or specify the name with: Worksheets("sheetname")
myRow = 4
Do While .Cells(myRow, 1) <> ""
categoryName = .Range("B" & myRow) 'Set variable equal to the category name
If Evaluate("ISREF('" & categoryName & "'!A1)") = False Then ' if no match was foundthen add the new sheet
Sheets.Add.Name = categoryName
End If
myRow = myRow + 1
Loop
End With
End Sub
I note that you're getting the sheet name from column B, but you're testing column A to ensure you've not reached the end of your list. Is that your intention? If not, change Do While .Cells(myRow, 1).. to Do While .Cells(myRow, 2).. to perform your test on column B

Extract same data-points from multiple sheets that have similar names

I have an excel workbook that have a subset of sheets with similar names: Data(US), Data(UK), Data(FR), Data(ES), etc... (in brackets there is the ISO code of the country which data refer to).
I would like to extract two data-points from all these sheets, and print them as a list in a new sheet to create a report.
Each sheet has the same structure inside (see here an image:
so that all the data-points are identified by coordinates for rows ("001","002", ... in row 6) and columns ("001", "002" in column D).
I am trying to write a code that does the following:
Open all sheets that have the name like: Data(**)
Inside the sheet, do a VLOOKUP to get the value corresponding to rows "001" and "002"
Print the data-points extracted in a new sheet, one after the other as a list in column D
Here is the code I wrote so far, which works only for the first sheet (Data(US)) and I included my questions as comments:
Sub ImportDataPoints()
Dim W As Worksheet, C&, F$
Dim D As String
'Take the folder path from cell D1
D = Worksheets("Input").Range("D1").Value
On Error Resume Next
'Target sheet to paste the data
Set W = ThisWorkbook.Worksheets("Data")
C = 3
Application.ScreenUpdating = False
'Open all workbooks in the folder that contain the following
F = Dir(D & "*FINANCIALDATA*" & "*.xlsx")
Do Until F = ""
C = C + 1
'Open the worksheet "Data(US)"
'### QUESTION: How to open all worksheets with similar names like Data(**)? ###
With Workbooks.Open(D & F).Worksheets("Data(US)")
'First datapoint to extract. Initial position: cell AA10.
'Do a VLOOKUP to search the value corresponding to coordinate "001"
.Range("AA10").FormulaR1C1 = "=VLOOKUP(""001"",C[-23]:C[-1],2,FALSE)"
'Move to AB10: if the previous value is empty, then give me zero
.Range("AB10").FormulaR1C1 = "=IF(RC[-1]="""",0,RC[-1])"
'Copy the value
.Range("AB10").Copy
'Paste the value in the Target sheet at row 10, column D
W.Cells(10, C).PasteSpecial xlPasteValues
'Do the same for the second datapoint and paste it in the Target sheet at row 11, column D
.Range("AA10").Offset(1, 0).FormulaR1C1 = "=VLOOKUP(""002"",C[-23]:C[-1],2,FALSE)"
.Range("AB10").Offset(1, 0).FormulaR1C1 = "=IF(RC[-1]="""",0,RC[-1])"
.Range("AB10").Offset(1, 0).Copy
W.Cells(11, C).PasteSpecial xlPasteValues
'### QUESTION: The macro should continue opening all the other sheets (Data(UK), Data(FR), Data(ES), etc...),
'### copying the datapoints 001-002 and pasting them in the same target sheet (column D, continuing from the row 11 onwards...)###
.Parent.Close False
End With
F = Dir
Loop
Set W = Nothing
Application.ScreenUpdating = True
End Sub
Does anybody know how to fix the code? Or if you can think to any other more efficient solution, all proposal are well accepted!
Many thanks in advance!
Something like this:
Sub ImportDataPoints()
Dim W As Worksheet, C&, F$
Dim D As String, wb As Workbook, targetRow As Long, sht As Worksheet
'Take the folder path from cell D1
D = Worksheets("Input").Range("D1").Value
'Target sheet to paste the data
Set W = ThisWorkbook.Worksheets("Data")
C = 3
Application.ScreenUpdating = False
'Open all workbooks in the folder that contain the following
F = Dir(D & "*FINANCIALDATA*.xlsx")
Do Until F = ""
C = C + 1
Set wb = Workbooks.Open(D & F)
targetRow = 10 'summary start row
For each sht in wb.worksheets
If sht.Name Like "Data(*)" Then
'....
'run your code for sheet sht
'....
targetRow = targetRow + 2 'next summary row
End With
Next sht
wb.close True
F = Dir
Loop
Set W = Nothing
Application.ScreenUpdating = True
End Sub

Copy a row of only data then move on to the next worksheet if no values left

I don't know how to create this section of the code. This is a template code that I've used to copy specific values from a cell from each worksheet into one master worksheet that compiles that data usually into one row.
Sub distribute()
Dim sh As Worksheet
Dim destsh As Worksheet
Dim i As Integer
Set destsh = ActiveWorkbook.Worksheets.Add
destsh.Name = "Master"
i = 1
For Each sh In ActiveWorkbook.Worksheets
***destsh.Cells(i, 1).Value = sh.Range("B7:B90").SpecialCells(xlCellTypeConstants).Select***
i = i + 1
Next
ActiveWorkbook.Worksheets("Master").Cells.EntireColumn.ColumnWidth = 30
ActiveWorkbook.Worksheets("Master").Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Master").UsedRange.UnMerge
ActiveWorkbook.Worksheets("Master").UsedRange.WrapText = False
End Sub
I want my code to go through each worksheet in my workbook and copy the column from the range B7:B90 and stop where there are no more values within each row of each worksheet, then moves on to the next worksheet. Some worksheets have 10 cells in one row, others have 60; in this scenario my master file would show 70 cells in column A from both worksheets. The code creates a master worksheet that compiles the worksheets row B in one column.
The section I need help with has been asterisked
Your code creates the Master sheet every time which will cause the program to fail when it tries to name the sheet in the next run. Also, in your iteration through all sheets, you are reading data from Master sheet as well which might give incorrect results. I can quickly think of below code. I have used the numerical notation for rows and cells. Also since the range is constant, i looped through the range that you specified
Sub distribute()
Dim sh As Worksheet
Dim destsh As Worksheet
Dim i As Integer: i = 1
Dim sheetName As String: sheetName = ""
Set destsh = ActiveWorkbook.Worksheets.Add
'Taking sheet name as input from user
sheetName = InputBox("Enter sheetname to aggregate data")
'Checking if sheetname was entered properly
If (sheetName <> "") Then
destsh.Name = sheetName
ActiveWorkbook.Worksheets("Master").Cells.EntireColumn.ColumnWidth = 30
ActiveWorkbook.Worksheets("Master").Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Master").UsedRange.UnMerge
ActiveWorkbook.Worksheets("Master").UsedRange.WrapText = False
masterSheetRow = 1
For Each sh In ActiveWorkbook.Worksheets
'Making sure that the sheet is not the master sheet while getting rows
If (sh.Name <> sheetName) Then
For i = 7 To 90
If (sh.Cells(i, 2).Value <> "") Then
destsh.Cells(masterSheetRow, 1).Value = sh.Cells(i, 2).Value
masterSheetRow = masterSheetRow + 1
End If
Next
End If
Next
Else
MsgBox ("Enter valid sheetname")
End If
End Sub

Excel VBA code to copy rows to relevant named sheets not working

I have found this code on this site from a previously answered question from two years ago.
The code looks at the rows of data on a Master Sheet and copies the relevant rows based on column D (Project) to the named sheet.
If a named sheet does not exist, a comment box is added to Column D, stating that the sheet name does not exist.
The code also looks at Column A (Invoice) and uses this a a unique ID so duplicate rows are not copied to the named sheets.
I amended the code to suit my needs (sheet titles, etc) but when I run the code, the relevant row is NOT copied to the named sheet but to the next sheet to the right.
I can't work out what is wrong with the code. Hoping someone can help!!!
Column A Column B Column C Column D
Invoice Date Amount Project
I18-1234 1/10/2018 $125.00 Project 1
I18-5678 10/10/2018 $1,500.00 Project 2
I18-2468 20/10/2018 $10,000.00 Project 1
I18-7931 15/10/2018 $300.00 Project 3
I18-1010 24/10/2018 $1,000.00 Project 1
I have a main sheet named "Master Sheet". This is where all data is entered.
Currently, I have another sheet named "Project 1".
The other sheets I have are named "Sheet2" and "Sheet3". (This is just while I test the code).
Sub Test()
Dim cell As Range
Dim cmt As Comment
Dim bolFound As Boolean
Dim sheetNames() As String
Dim lngItem As Long, lngLastRow As Long
Dim sht As Worksheet, shtMaster As Worksheet
Dim MatchRow As Variant
'Set master sheet
Set shtMaster = ThisWorkbook.Worksheets("Master Data")
'Get the names for all other sheets
ReDim sheetNames(0)
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> shtMaster.Name Then
sheetNames(UBound(sheetNames)) = sht.Name
ReDim Preserve sheetNames(UBound(sheetNames) + 1)
End If
Next sht
ReDim Preserve sheetNames(UBound(sheetNames) - 1)
For Each cell In shtMaster.Range("D2:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
bolFound = False
' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
bolFound = True
Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))
' now use a 2nd Match, to find matches in Unique column "A"
MatchRow = Application.Match(cell.Offset(, -3).Value, sht.Range("A:A"), 0)
If Not IsError(MatchRow) Then
shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(MatchRow, 1)
Else '<-- no match in sheet, add the record at the end
On Error GoTo SetFirst
lngLastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
On Error GoTo 0
shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1)
End If
End If
If bolFound = False Then
For Each cmt In shtMaster.Comments
If cmt.Parent.Address = cell.Address Then cmt.Delete
Next cmt
cell.AddComment "no sheet found for this row"
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End If
Set sht = Nothing
Next
Exit Sub
SetFirst:
lngLastRow = 1
Resume Next
End Sub
change your part of the code :
' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
bolFound = True
Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))
to
' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
bolFound = True
Set sht = ThisWorkbook.Worksheets(cell.Value)

Need VB code that will merge two sheets into a new sheet

I am new to VB, and need some help. I have an excel 2013 workbook that has 2 sheets. Sheet1 is list of employee names (column A has 20 names), dob (column B), etc, and Sheet2 is a blank evaluation form. I need a code that will copy the entire Sheet2 (the blank form) and paste into a new Sheet3, and also pull the EmpName from row1 to a specified cell on Sheet3 (D4), same with DOB (J4), etc. I need it to repeat this process for every name on Sheet1. End goal is to have a workbook that contains 20 sheets, one for each employee, in the form of an evaluation. It would also be terrific if this code could name the tab the employee name. Is this possible? I've searched online extensively, and cannot find anything fitting.
Here is my current code. Like I said, I'm a VBA newbie. The code creates new sheets from the employee list, and copies data, but now I need it to also copy the entire sheet2 (eval form), and place the data (name cell A1 from employee list) into the form on sheet3 (new sheet) in cell D4.
Sub CreateSheetsFromEmployeeList()
Dim nameSource
Dim nameColumn
Dim nameStartRow As Long
Dim nameEndRow As Long
Dim employeeName As String
Dim newSheet As Worksheet
nameSource = "Ayre"
nameColumn = "A"
nameStartRow = 2
nameEndRow = Worksheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row
Do While (nameStartRow <= nameEndRow)
employeeName = Sheets(nameSource).Cells(nameStartRow, nameColumn)
employeeName = Trim(employeeName)
If (employeeName <> vbNullString) Then
On Error Resume Next 'do not throw error
Err.Clear 'clear any existing error
Sheets(employeeName).Name = employeeName
If (Err.Number > 0) Then
Err.Clear
On Error GoTo -1
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Name = employeeName
Sheets(nameSource).Activate
LastCol = ActiveSheet.Cells(nameStartRow, Application.Columns.Count).End(xlToLeft).Column
Range(Cells(nameStartRow, 1), Cells(nameStartRow, LastCol)).Select
Selection.Copy
Sheets(employeeName).Activate 'NEW
Sheets(employeeName).Cells(1, "A").PasteSpecial
[a1].Select 'NEW
Application.CutCopyMode = False
Sheets(employeeName).Columns("A:K").AutoFit
End If
End If
nameStartRow = nameStartRow + 1
Loop
End Sub
Record a macro
When you record a macro, the macro recorder records all the steps required to complete the actions that you want your macro to perform. Iterate your action once, stop recording, then view the macro to repeat and build out your final automation macro.
This code demonstrates the basic principles you need:
Sub ExampleForAngel()
Dim names As Worksheet
Set names = Worksheets("Sheet1")
Dim eval As Worksheet
Set eval = Worksheets("Sheet2")
Dim index As Long
index = 0
Dim name As String
While (names.Range("A1").Offset(index, 0).Value <> "")
name = names.Range("A1").Offset(index, 0)
eval.Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.name = name
ActiveSheet.Range("A2").Value = name
index = index + 1
Wend
End Sub

Resources