it's my first time posting on Stack Overflow. I am trying to use VBA to get it to create a new worksheet based on a cell value in sheet 1. But if the sheet already exists I need it to open that sheet instead. I'm having difficulty with this as I don't actually know the name of the sheet. I thought I could do this if I create another sheet where it stores the names of projects, using a counter. It shows me I have run-time error 91. This is the code I currently have:
Public Sub DailyReport()
Dim project As Range
project = Worksheets("Target Flow").Range("B3")
Dim i As Integer
i = 1
If Worksheets("Target Flow").Range("B3") <>
Worksheets("Projects").Cells(1000, 1).Value Then
Worksheets("Target Flow").Range("B3").Select
Selection.Copy
Worksheets("Projects").Activate
Cells(i, 1).Select
ActiveSheet.Paste
Dim WS As Worksheet
Set WS = Sheets.Add(After:=Sheets(Worksheets.Count))
WS.Name = project.Value
i = i + 1
Else
Worksheets("Target Flow").Activate
Worksheets(ActiveSheet.Range("B3").Value).Activate
End If
End Sub
If anyone could guide me in the right direction, I'd be grateful!!
This code will scan all sheets in the active workbook to see if there is a name match, if there is it will activate it. After the loop if it doesn't see a match was made it will create it.
Dim targetSheetName As String
Dim targetSheetFound As Boolean
Dim sheet As Worksheet
targetSheetName = Worksheets("Target Flow").Range("B3")
targetSheetFound = False
For Each sheet In ActiveWorkbook.Worksheets
If sheet.Name = targetSheetName Then
targetSheetFound = True
sheet.Activate
End If
Next
If Not targetSheetFound Then
set sheet = Sheets.Add
sheet.Name = targetSheetName
End If
Related
I am working with an excel sheet that has a bunch of sheets with data in tables. I am trying to consolidate the sheets. I do not want the copied data to be in tables. I am able to find the tables range address for all the sheets except one, which is retunring an address of $1:$104. All the other ranged are like this "$A$1:$J$43" . When I try to copy this table using the address it returns , I get the runtime error "1004". For now , the code rewrite all the tables in the same place, but I will be changing the code to copy the tables into different places in the destination sheet.
Here is my code:
Sub mergeWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with
object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Dim mLastRow As Integer
Dim LastRow As Integer
Dim rngFound As Range
Dim i As Integer
Set wrk = ActiveWorkbook 'Working in active workbook
'We don't want screen updating
Application.ScreenUpdating = False
' would rather not do a loop but using a function to check and delete sheet renders error
For Each Sheet In ActiveWorkbook.Worksheets
If Sheet.Name = "Master" Then
Application.DisplayAlerts = False
Sheets("Master").Delete
Application.DisplayAlerts = True
End If
Next Sheet
' Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(Before:=wrk.Worksheets(1))
' Rename the new worksheet
trg.Name = "Master"
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Name Like "*Attri*" Then
Debug.Print sht.Name
'Find the last row of the master sheet
Set rngFound = trg.UsedRange.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
If Not rngFound Is Nothing Then
'you found the value - do something
mLastRow = rngFound.Row
Debug.Print "Last row of master " & rngFound.Address, mLastRow
Else
' you didn't find anything becasue sheet is empty - first pass
mLastRow = 0
End If
For Each tbl In sht.ListObjects
'Do something to all the tables...
Debug.Print tbl.Name
Debug.Print tbl.Range.Address
'Put data into the Master worksheet
tbl.Range.Copy Destination:=trg.Range("B1")
Next tbl
' trg.Cells(mLastRow + 1, 1).Value = "Tab Name"
' trg.Cells(mLastRow + 1, 1).Font.Bold = "True"
' trg.Range("A" & mLastRow + 1).Value = sht.Name
Debug.Print "-------"
Else
' Debug.Print "error " & sht.Name & " is missing header "
End If
Next sht
That funny range is obviously there. What you can do is to control the size of the data to be copied. If you can set a meaningful maximum value for table width then you can limit size like this:
const MAXWID = 1000
Dim r As Range
If tbl.Range.Columns.Count > MAXWID Then
Set r = tbl.Range.Resize(, MAXWID)
Else
Set r = tbl.Range
End If
r.Copy Destination:=trg.Range("B1")
Funny things can happen to the height of the table(s), too, so you may want to implement this for the other dimension. For appending the tables you need to know where the first empty row is:
FirstEmptyRow = trg.Range("B1").SpecialCells(xlCellTypeLastCell).Row + 1
r.Copy Destination:=trg.Cells(FirstEmptyRow, "B")
For sheet manipulation you need to use On Error ... like this:
Application.DisplayAlerts = False
On Error Resume Next
Set trg = wrk.Sheets("Master")
If Err.Number = 0 Then ' sheet exists
trg.Usedrange.Delete ' delete all existing data -> have a clean sheet
Else ' sheet doesn't exist, Add new worksheet as the first worksheet
Set trg = wrk.Worksheets.Add(Before:=wrk.Worksheets(1))
If Err.Number <> 0 Then < sheet is not added, handle error...>
trg.Name = "Master"
End If
On Error Goto 0
Application.DisplayAlerts = True
It's worth taking the time to learn how error handling works in VBA.
And finally: use Option Explicit. It pays.
I'm using this macro to copy columns A and B from all of my sheets into a new sheet named Master. What I notice is that entire sheets worth of information are missing in the master sheet and I can't figure out why. The format for my sheets is column A has a string of characters that follow this structure: M2,004,005,004,007,17,096,01:07:45,45 and column B is just a date such as 4/19/2017.
I have hundreds of these sheets in my workbook and each has 224 rows that I need to copy into a single master sheet. Could anyone help me figure out how to get this code to stop skipping sheets?
Thanks.
Sub CreateMaster()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Master"
Sheets(2).Activate
Range("A1:B1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1:B1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1:B1").Select
Selection.CurrentRegion.Select
Selection.Copy Destination:=Sheets(1).Range("A65536:B65536").End(xlUp)(2)
Next
End Sub
while searching for solutions online, I came across this macro that seems to do the same thing, but also seems to skip the exact same sheets as my macro does.
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object
variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
as a workaround, since only the most recent data is immediately pertinent, I worked around it, but deleting the first 150 sheets. that still left around 100 sheets for my macro to work on, but now the missing pieces of data seem to be there. I wonder if there's something about the quantity of sheets that is causing this to malfunction?
Comments may not get it across correctly. Restructure your loop (and add the variables mentioned).
Dim x as Long
Dim thisSht as Worksheet
For x = 1 to wrk.Worksheets.Count
set thisSht = wrk.Worksheets(x)
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = thisSht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next x
my VBA code is copy/pasting rows from several sheets in the workbook into another sheet based on a specific input criteria. It uses an InStr search to find the input criteria on sheets starting with "E" in column D between rows 17-50 - which is working good.
However, when activiting the sub through a button it only copy/pasts the first entry it finds and jumps to the next worksheet. In debug.mode it finds all entries in one worksheet, does copy/paste and only then jumps to the next worksheet.
What do I need to change?
Sub request_task_list()
Dim rPlacementCell As Range
Dim myValue As Variant
Dim i As Integer, icount As Integer
myValue = InputBox("Please enter the Name (Name or Surname) of the Person whos task you are looking for", "Input", "Hansen")
If myValue = "" Then
Exit Sub
Else
Set rPlacementCell = Worksheets("Collect_tool").Range("A3")
For Each Worksheet In ActiveWorkbook.Worksheets
'Only process if the sheet name starts with 'E'
If Left(Worksheet.Name, 1) = "E" Then
Worksheet.Select
For i = 17 To 50
If InStr(1, LCase(Range("D" & i)), LCase(myValue)) <> 0 Then
'In string search for input value from msg. box
'Copy the whole row if found to placement cell
icount = icount + 1
Rows(i).EntireRow.Copy
rPlacementCell.PasteSpecial xlPasteValuesAndNumberFormats
Range("D2").Copy
rPlacementCell.PasteSpecial xlPasteValues
Set rPlacementCell = rPlacementCell.Offset(1)
End If
Next i
End If
Next Worksheet
Worksheets("collect_tool").Activate
Range("B3").Activate
End If
End Sub
This code works for me:
Sub request_task_list()
Dim rPlacementCell As Range
Dim myValue As Variant
Dim i As Integer
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Set wrkBk = ActiveWorkbook
'or
'Set wrkBk = ThisWorkbook
'or
'Set wrkBk = Workbooks.Open("C:/abc/def/hij.xlsx")
myValue = InputBox("Please enter the Name (Name or Surname) of the Person whos task you are looking for", "Input", "Hansen")
If myValue <> "" Then
Set rPlacementCell = wrkBk.Worksheets("Collect_tool").Range("A3") 'Be specific about which workbook the sheet is in.
For Each wrkSht In wrkBk.Worksheets
'Only process if the sheet name starts with 'E'
If Left(wrkSht.Name, 1) = "E" Then
For i = 17 To 50
'Cells(i,4) is the same as Range("D" & i) - easier to work with numbers than letters in code.
If InStr(1, LCase(wrkSht.Cells(i, 4)), LCase(myValue)) > 0 Then 'Be specific about which sheet the range is on.
'In string search for input value from msg. box
'Copy the whole row if found to placement cell
wrkSht.Rows(i).EntireRow.Copy
rPlacementCell.PasteSpecial xlPasteValuesAndNumberFormats
rPlacementCell.Value = wrkSht.Cells(2, 4).Value
Set rPlacementCell = rPlacementCell.Offset(1)
End If
Next i
End If
Next wrkSht
Worksheets("collect_tool").Activate
Range("B3").Activate
End If
End Sub
I'm guessing your code failed at this point: For Each Worksheet In ActiveWorkbook.Worksheets. Worksheet is a member of the Worksheets collection and I don't think it can be used this way. Note in my code I've set wrkSht as a Worksheet object and then used wrkSht to reference the current worksheet in the loop.
Good morning,
I'm attempting to copy data from multiple worksheets (in cells M78:078) into one, where the name in the column (L) of the summary sheet matches to the worksheet name (pasting into columns Z:AA in the summary sheet.
At present the below code is erroring out:
Sub Output_data()
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ActiveSheet.Range("L:L").Value = wkSht.Name Then
ws.Range("M78:O78").Copy
ActiveSheet.Range("L").CurrentRegion.Copy Destination:=wkSht.Range("Z:AA").Paste
End If
Next ws
Application.ScreenUpdating = True
End Sub
Any help would be great.
DRod
Something like this should work for you. I commented the code in an attempt to explain what it does.
Sub Output_data()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsGet As Worksheet
Dim LCell As Range
Dim sDataCol As String
Dim lHeaderRow As Long
sDataCol = "L" 'Change to be the column you want to match sheet names agains
lHeaderRow = 1 'Change to be what your actual header row is
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Summary") 'Change this to be your Summary sheet
'Check for values in sDataCol
With ws.Range(sDataCol & lHeaderRow + 1, ws.Cells(ws.Rows.Count, sDataCol).End(xlUp))
If .Row <= lHeaderRow Then Exit Sub 'No data
'Loop through sDataCol values
For Each LCell In .Cells
'Check if sheet named that value exists
If Evaluate("ISREF('" & LCell.Text & "'!A1)") Then
'Found a matching sheet, copy M78:O78 to the corresponding row, column Z and on
Set wsGet = wb.Sheets(LCell.Text)
wsGet.Range("M78:O78").Copy ws.Cells(LCell.Row, "Z")
End If
Next LCell
End With
End Sub
I am trying to dynamically generate a custom number of worksheets based on a template that we use regularly in excel using VBA.
I have created an "Overview" page where we can input a range which will be used to name the new worksheets but then would like to use a hidden "Master" worksheet to generate the content of these new worksheets.
My code below currently generates the correct number of pages based on the range AND copies our master template page but does not combine the two and leaves them in separate pages.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set masterSheet = ThisWorkbook.Worksheets("Master")
Set MyNames = Range("A1:A6").CurrentRegion ' load range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell range
masterSheet.Copy ThisWorkbook.Sheets(Sheets.Count) 'copy master template sheet
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
As you can see, the code generates both the named (blank) worksheets AND copies my master worksheet which defaults to naming as "Master()".
So we just need to replace this line:
Sheets.Add.Name = MyNewSheet.Value
with this line:
ActiveSheet.Name = MyNewSheet.Value
Loop through the list and copy the sheet if the sheet does not already exist.
Sub CopyMaster()
Dim ws As Worksheet, sh As Worksheet
Dim Rws As Long, rng As Range, c As Range
Set sh = Sheets("Overview")
Set ws = Sheets("Master")
With sh
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
End With
For Each c In rng.Cells
If WorksheetExists(c.Value) Then
MsgBox "Sheet " & c & " exists"
Else:
ws.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = c.Value
End If
Next c
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function