VBA noob here. I've got Dashboard, Master, and Aggregate sheets. I created a macro so that when one presses the "create copies" button, the Master sheet is copied into new "Tool" sheets named based on a list. After the new sheets are created, I'd like specific columns from each of these new sheets to be copied into the aggregate (or inserted as new table columns). It's difficult when the amount of sheets being added and their names are variable.
Here's the code for creating the new sheets:
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Dim tbl As ListObject
Set MyRange = Sheets("Dashboard").Range("A24:A28")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add after:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Worksheets("RTM - Master").Cells.Copy ActiveSheet.Range("A1")
ActiveSheet.ListObjects(1).Name = MyCell.Value
ActiveSheet.Cells(1, 6).Value = MyCell.Value & " " & "Capability"
ActiveSheet.Cells(1, 7).Value = MyCell.Value & " " & "LOE"
ActiveSheet.Cells(1, 8).Value = MyCell.Value & " " & "Pts"
Range("f1", Range("f1").End(xlDown)).Select
Next MyCell
End Sub
Thanks in advance!
Related
I have four sheets with raw data that I would like to be duplicated in my workbook and left alone for cross reference. Then I would like to remove all rows above the cell with the text "proj def" (it appears twice, but there are cells that lie in between the two appearances - which will be evident in my code). I would like to do this for the first four sheets of my workbook while leaving the original duplicated worksheets alone but am only able to do so with the first worksheet labeled "ptd". I have tried to activate the next worksheet "ytd" and even delete the original worksheet "ptd" to see if it would allow me to change the location of myRange but I have had no success. Essentially I want to run this code in sub methods, two for the first sheet "ptd", two more for the second sheet "ytd", another 2 for "qtr" and the final 2 for "mth". Any edits to my sample code would be much appreciated.
Sub part1()
Worksheets("ptd").Copy After:=Worksheets("mth")
Worksheets("ytd").Copy After:=Worksheets("ptd (2)")
Worksheets("qtr").Copy After:=Worksheets("ytd (2)")
Worksheets("mth").Copy After:=Worksheets("qtr (2)")
End Sub
Sub part2()
Worksheets("ptd").Activate
Set rngActiveRange = ActiveCell
Dim MyRange As Range
Set MyRange = ActiveSheet.Range("A:A")
MyRange.Find("Customer Unit", LookIn:=xlValues).Select
rngActiveRange.Offset(-1, 0).Select
Range(rngActiveRange.Row & ":" & 1).Rows.Delete
End Sub
Sub part3()
Dim MyRange As Range
Set MyRange = ActiveSheet.Range("A:A")
MyRange.Find("Project Definition", LookIn:=xlValues).Select
ActiveCell.Offset(-1, 0).Select
Range(ActiveCell.Row & ":" & 1).Rows.Delete
End Sub
Sub part4()
Worksheets("ytd").Activate
Set rngActiveRange = ActiveCell
Dim MyRange As Range
Set MyRange = ActiveSheet.Range("A:A")
MyRange.Find("Customer Unit", LookIn:=xlValues).Select
rngActiveRange.Offset(-1, 0).Select
Range(rngActiveRange.Row & ":" & 1).Rows.Delete
End Sub
Sub part5()
Dim MyRange As Range
Set MyRange = ActiveSheet.Range("A:A")
MyRange.Find("Project Definition", LookIn:=xlValues).Select
ActiveCell.Offset(-1, 0).Select
Range(ActiveCell.Row & ":" & 1).Rows.Delete
End Sub
If I understand correctly, the below should work. The main thing I did was re-write with avoiding the use of .Select/.Activate.
Sub remove_Rows()
Dim ws As Worksheet
Dim foundCel As Range
' Copy sheets
Worksheets("ptd").Copy After:=Worksheets("mth")
Worksheets("ytd").Copy After:=Worksheets("ptd (2)")
Worksheets("qtr").Copy After:=Worksheets("ytd (2)")
Worksheets("mth").Copy After:=Worksheets("qtr (2)")
' Start removing rows
For Each ws In ActiveWorkbook.Worksheets
With ws
If InStr(1, .Name, "(") = 0 Then
Set foundCel = .Range("A:A").Find("Customer Unit", LookIn:=xlValues)
.Range(foundCel.Offset(-1, 0).Row & ":" & 1).Rows.Delete
Set foundCel = .Range("A:A").Find("Project Definition", LookIn:=xlValues)
.Range(foundCel.Offset(-1, 0).Row & ":" & 1).Rows.Delete
End If
End With
Next ws
End Sub
Hi I'm trying to create a copy of a worksheet in a workbook for each entry in a range, then rename the worksheet based on the value of the current cell in that range. It was working before, but now it doesn't name the new sheets. If I make blank worksheets, it will name them, however if I copy the worksheet it won't name the worksheet properly. I am also trying to set the value of C1 on each sheet to the value that is from the range. Below is my code:
Sub CreateSEMSheets()
On Error GoTo GetOut
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Strategic End Market Data").Range("SEMListGenerated")
For Each MyCell In MyRange
If MyCell.Value = "" Then GoTo GetOut
Sheets("StrategicMktPlan").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "SMP - " & MyCell.Value
Sheets(Sheets.Count).Range("C1").Value = MyCell.Value
Next MyCell
GetOut:
End Sub
Please help!!! Thanks in advance.
Edit: I figured out why it's not working - there was a hidden sheet that was the last sheet in the workbook and it was renaming that over and over. Any idea how to prevent this?
After Copy() method of Worksheet object the newly created worksheet is the active one:
For Each MyCell In MyRange
If MyCell.Value = "" Then GoTo GetOut
Sheets("StrategicMktPlan").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = "SMP - " & MyCell.Value
.Range("C1").Value = MyCell.Value
End With
Next MyCell
Per your edit, you could use this:
Sub VisibleSheetsCount()
'UpdatebyKutoolsforExcel20150909
' https://www.extendoffice.com/documents/excel/3187-excel-count-visible-sheets.html
Dim xSht As Variant
Dim I As Long
For Each xSht In ActiveWorkbook.Sheets
If xSht.Visible Then I = I + 1
Next
MsgBox I & " sheets are visible", , "Kutools for Excel"
End Sub
Then do .Copy(After:=Sheets(I)) I think would work.
I am really new to code so excuse the simple question:
I currently have the below code which creates new tabs in excel from a list which works perfectly, however I now have a 'template 2' and I would like it to create template 1 then template 2 for each item in the 'input' tab using range F8 for 'template 1' and G8 for 'template 2'. I can get it to do all the items in F8 for template 1 and then all the items in G8 for template 2 but I cant manage to get it to alternate.
I ultimately want to create template 1 then template 2, copy and paste values into an new file and save, then repeat for the next line down in the input tab.
Thank you in advance
Sub Addnewsheets()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Input").Range("F8")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Template 1").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets
Next MyCell
Worksheets("End").Move after:=Worksheets(Worksheets.Count)
End Sub
If I interpret your issue correctly, just add these two lines before the Next MyCell
Sheets("Template 2").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Offset(, 1).Value 'Renames the new worksheets based on column G
For clarity sake, the For Loop becomes:
For Each MyCell In MyRange
Sheets("Template 1").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets
Sheets("Template 2").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Offset(, 1).Value 'Renames the new worksheets based on column G
Next MyCell
I'm on XL2007 - Windows 7.
I need an element of error handling in the below code.
Some of the values in range rngburndown do not exist as worksheets, and i need the VBA to skip these cells, and copy the rows that do exist as worksheets to the nextavailable row in the matching worksheet name.
Sub Retrieve_Forecasts()
Dim objWorksheet As Worksheet
Dim rngBurnDown As RANGE
Dim rngCell As RANGE
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As RANGE
'DEFINE SOURCE WORKSHEET
Set objWorksheet = ThisWorkbook.Worksheets("Forecasts")
'DEFINE LIST OF FORECASTS - INCLUDING VALUES WHICH MAY NOT EXIST AS WORKSHEETS
Set rngBurnDown = objWorksheet.RANGE("A2:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'LOOP THROUGH RANGE
For Each rngCell In rngBurnDown.Cells
objWorksheet.Select
If rngCell.Value <> "" Then
'SELECT ROW
rngCell.EntireRow.Select
'COPY
Selection.Copy
'FIND AND PASTE WHERE WORKSHEET NAME MATCHES FORECAST LIST
Set objNewSheet = ThisWorkbook.Worksheets(rngCell.Value)
objNewSheet.Select
Set rngNextAvailbleRow = objNewSheet.RANGE("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
RANGE("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
End Sub
You could use the commands "On Error GoTo 0" to ignore all errors or use "On Error Resume Next" to ignore the error and execute the next instruction as shown in https://msdn.microsoft.com/en-us/library/5hsw66as.aspx
Example:
For Each rngCell In rngBurnDown.Cells
On Error GoTo 0
objWorksheet.Select
If rngCell.Value <> "" Then
'SELECT ROW
rngCell.EntireRow.Select
'COPY
Selection.Copy
'FIND AND PASTE WHERE WORKSHEET NAME MATCHES FORECAST LIST
Set objNewSheet = ThisWorkbook.Worksheets(rngCell.Value)
objNewSheet.Select
Set rngNextAvailbleRow = objNewSheet.RANGE("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
RANGE("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
I have two sheets containing the employee records.
Sheet1 contains the Event Date, CardNo, Employee Name, Dept Id, Employee No, Entry and Exit Time, Total Working Hours, Status, ConcatinatedColumn and Remarks (copied through vlookup from sheet2)
Sheet2 contains ConcatinatedColumn, Event Date, Employee No, Name, Remarks.
If the data in the remarks column of sheet2 is "Sick Off" then that row should be inserted to sheet1 without effecting the previous records.
I've already written the code for it but it does not work.
Would be really grateful if anyone can help me out !
THANKS IN ADVANCE !
MY CODE :
Sub SickOff()
Dim objWorksheet As Sheet2
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Sheet1
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count, "G").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells
objWorksheet.Select
If rngCell.Value = "Sick Off" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
Let's say you have data in Sheet2 as shown below
Let's say the end of data in Sheet1 looks like this
Logic:
We are using autofilter to get the relevant range in Sheet2 which match Sick Off in Col G. Once we get that, we copy the data to the last row in Sheet1. After the data is copied, we simply shuffle data across to match the column headers. As you mentioned that the headers won't change so we can take the liberty of hardcoding the column names for shuffling this data.
Code:
Paste this code in a module
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long, wsOlRow As Long, OutputRow As Long
Dim copyfrom As Range
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> This is the row where the data will be written
OutputRow = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row + 1
With wsO
wsOlRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter G on "Sick Off"
With .Range("G1:G" & wsOlRow)
.AutoFilter Field:=1, Criteria1:="=Sick Off"
Set copyfrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
If Not copyfrom Is Nothing Then
copyfrom.Copy wsI.Rows(OutputRow)
'~~> Shuffle data
With wsI
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & OutputRow & ":A" & lRow).Delete Shift:=xlToLeft
.Range("F" & OutputRow & ":F" & lRow).Copy .Range("K" & OutputRow)
.Range("F" & OutputRow & ":F" & lRow).ClearContents
.Range("B" & OutputRow & ":B" & lRow).Copy .Range("E" & OutputRow)
.Range("B" & OutputRow & ":B" & lRow).ClearContents
End With
End If
End Sub
Output: