So I'm trying to finish a macro that selects all worksheets with similar names and moves them before a certain sheet in a workbook. The user can add as many pages with these names so i couldn't just use an array function to move them. This is what I have so far:
Sub Copier()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim x As Integer
x = InputBox("Enter Number of Additional Features")
For numtimes = 1 To x
ActiveWorkbook.Sheets(Array("Data Collection", "Findings", "Visual Findings")).Copy _
Before:=ActiveWorkbook.Sheets("Final Results")
'Allows user to create as many pages as necessary
Dim ws As Worksheet, flg As Boolean
For Each ws In Worksheets
If (ws.Name) Like "*Data Collection*" Then
ws.Select Not flg
flg = True
End If
Next
'Selects all sheets for "Data Collection"
'Now I need to move all of those selected before a certain sheet at the
beginning of the workbook
'I cant seperate the copy functions because some formulas from data collection have to carry
over to the other copied sheets
'Sheet2.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You may use:
Dim sheetNames As String
Dim ws As Worksheet, flg As Boolean
For Each ws In Worksheets
If ws.Name Like "*Data Collection*" Then sheetNames = sheetNames & "|"
Next
If sheetNames <>"" Then ActiveWorkbook.Sheets(Split(Left(sheetNames, Len(sheetNames) - 1),"|").Move Before:=ActiveWorkbook.Sheets("Final Results")
Related
I have a workbook that will contain worksheets with the text “benefits” in the sheet name. For example; MEDICALBenefits or DENTALBenefits. There will always be at least one, but there could be several.
I am trying to write a macro that will find the worksheet(s) with the text “benefits” in the sheet name AND at least one instance of the word TRUE in row 40.
When these two criteria are met then I need to create a new worksheet using the same worksheet name but replacing the text “Benefits” with the text “Final”, In other words; If the worksheet MEDICALBenefits has TRUE in one or more cells in row 40 then a new sheet called MEDICALFinal would be created.
Likewise, if the worksheet DENTALBenefits has TRUE in one or more cells in row 40 then a new sheet called DENTALFinal would be created.
I then need it to loop through all the sheets looking for “Benefits” in the name and TRUE in row 40 and create a new sheet.
This is the code I have so far, but need help with naming the new sheets.
Jordan
'Look for worksheet names *benefits* with checkbox(s) = true
Sub CreateFinalWorksheet()
Dim sh As Worksheet
Dim iVal As Integer
Application.ScreenUpdating = False
For Each sh In ActiveWorkbook.Sheets
iVal = Application.WorksheetFunction.CountIf(Range("40:40"), "TRUE")
If (LCase$(sh.Name) Like "*benefits*") And (iVal > 0) Then Call AddWorksheet
Next sh
Application.ScreenUpdating = True
End Sub
'Called from CreateFinalWorksheet.
'Add worksheet with same sheet name replacing *benefits* with *final*
Sub AddWorksheet()
Dim sh As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "MedicalFinal"
End With
End Sub
edited after OPs clarification he wants to find all "*benefits" sheets
in
iVal = Application.WorksheetFunction.CountIf(Range("40:40"), "TRUE")
you're missing current sh worksheet reference, so you want to write as follows:
iVal = Application.WorksheetFunction.CountIf(sh.Range("40:40"), "TRUE")
For what above and for your main issue, I'd go like follows:
Sub CreateFinalWorksheet()
Dim sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ActiveWorkbook.Sheets
If (LCase$(sh.Name) Like "*benefits") Then
If WorksheetFunction.CountIf(sh.Rows(40), "TRUE") = 0 Then AddWorksheet sh.Name
End If
Next sh
Application.ScreenUpdating = True
End Sub
Sub AddWorksheet(shtName As String)
Dim sh As Worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.count)).Name = Replace(LCase$(shtName), "benefits", "Final")
End With
End Sub
Add a parameter to your AddWorksheet routine, let it be the "benefits"worksheet
If (LCase$(sh.Name) Like "*benefits*") And (iVal > 0) Then AddWorksheet sh
Sub AddWorksheet(benef as worksheet)
....
ws.name = Replace(benef.name, "benefits", "Final", , vbTextCompare)
Eventually, you can also do other things inside this sub, such as copying some data from the parameter worksheet benef.
I'm writing a macro in VBA for Excel. I want it to replace all worksheets except for a few. First there is a loop which deletes the unwanted sheets, and then comes another one which creates new sheets to repace them! On a first run, the macro removes unwanted sheets. However, if it is run again it seems to be unable to delete the sheets it previously created, which causes a name duplicity error.
(The rng variable is supposed to extend across the entire row but I haven't gotten to fixing that yet.)
Hope you guys can provide some insight, much appreciated!
sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
If Not Current.Name = "Data" Then
Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
' Define range for loop
Dim rng As Range, cell As Range
Set rng = Sheets("Data").Range("A5:M5")
' Loop through entire row, looking for employees
For Each cell In rng
If cell.Value = "Nummer" Then
' Make new chart for employee
With Charts.Add
.ChartType = xlLineMarkers
.Name = cell.Offset(-1, 1).Value
.HasTitle = True
.ChartTitle.Text = cell.Offset(-1, 1).Value
' Set data (dynamic) and x-axis (static) for new chart
.SetSourceData Source:=Sheets("Data").Range(cell.Offset(-2, 3), cell.Offset(7, 4))
.Axes(xlValue).MajorGridlines.Select
.FullSeriesCollection(1).XValues = "=Data!E4:E12"
' Add trendlines
.FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (DDE)"
.FullSeriesCollection(2).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (SDE)"
End With
' Chart is moved to end of all sheets
Sheets(cell.Offset(-1, 1).Value).Move _
after:=Sheets(Sheets.Count)
End If
Next cell
End Sub
No need to define the worksheet with the Worksheets()
Sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Worksheets
If Not Current.Name = "Data" Then
Current.Delete
End If
Next Current
Application.DisplayAlerts = True
End sub
The Following code (minor changes worked in my workbook), are you sure you have the names you put in the If in your Workbook ?
Anyway, I think it's better to use Select for multiple possible mathces
Sub Terminator()
Dim Current As Excel.Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Sheets
If Not (Current.Name = "Data") Then
ActiveWorkbook.Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
End Sub
Solution to the deletion is supplied by RGA, but in case you want to avoid several AND statements for each sheet that you want to retain, you can utilize a function similar to the isInArray below:
Sub Terminator()
Dim Current As Variant
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ThisWorkbook.Sheets
If Not isInArray(Current.Name, Array("Data")) Then
Current.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Function isInArray(theValue As String, vArr As Variant) As Boolean
Dim vVal As Variant
isInArray = False
For Each vVal In vArr
If LCase(vVal) = LCase(theValue) Then
isInArray = True
End If
Next
End Function
EDIT:
function that takes a worksheet name as argument, and returns a worksheet object of that name. If the name is allready taken, the existing sheet is deleted and a new one created:
'example of use:
'set newWorksheet = doExist("This new Sheet")
Function doExist(strSheetName) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTest As Worksheet
Dim nWs As Worksheet
Set wsTest = Nothing
On Error Resume Next
'Set wsTest = wb.Worksheets(strSheetName) 'commented out in Edit of Edit
Set wsTest = wb.Sheets(strSheetName) 'as a comment for one of the other threads reveal, the error could be the deletion of Worksheets, which would be a subgroup to Sheets of which graph sheets are no a part
On Error GoTo 0
If Not wsTest Is Nothing Then
Application.DisplayAlerts = False
wsTest.Delete
Application.DisplayAlerts = True
End If
'Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count)) 'Edit of Edit, the later call to Charts.Add does this for you
'doExist.Name = strSheetName 'Edit of Edit, no need to return anything
End Function
I'm able to import worksheets successfully to my workbook. But is it possible to just import the columns that I want? The data is really huge and I don't want to have the trouble to go through every part of the cells.
Below are my codes:
Sub ImportSheet()
Dim wb As Workbook
Dim activeWB As Workbook
Dim sheet As Worksheet
Dim FilePath As String
Dim oWS As String
Set activeWB = Application.ActiveWorkbook
FilePath = "C:\Report.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = Application.Workbooks.Open(FilePath)
wb.Sheets("Report").Copy After:=activeWB.Sheets(activeWB.Sheets.Count)
activeWB.Activate
wb.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Not sure if I'm breaking protocol here but this is a completely different approach and the option to Add Another Answer was there. This method uses the 'copy to new worksheet' approach which should be easier on limited resources.
Sub ImportSheet()
Dim iWB As Workbook, aWB As Workbook, ws As Worksheet
Dim FilePath As String, v As Long, vCOLs As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = "C:\Report.xlsx"
vCOLs = Array(1, 13, 6, 18, 4, 2) 'columns to copy in this order
Set aWB = Application.ActiveWorkbook
With aWB
.Sheets.Add after:=.Sheets(.Sheets.Count)
Set ws = .Sheets(.Sheets.Count)
'.name = "Report" 'you can name the new ws but do NOT duplicate
End With
Set iWB = Application.Workbooks.Open(FilePath)
With iWB.Sheets("Report").Cells(1, 1).CurrentRegion
.Cells = .Cells.Value
For v = LBound(vCOLs) To UBound(vCOLs)
.Columns(vCOLs(v)).Copy Destination:=ws.Cells(1, v + 1)
Next v
End With
iWB.Close False
Set iWB = Nothing
Set ws = Nothing
Set aWB = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
My primary concern here is not knowing the layout of the 'Report' worksheet. The boundaries of the .CurrentRegion are dictated by the first fully blank column to the right and the first fully blank row down. A block of data rarely has this but worksheets called Report often do.
You are closing the freshly opened workbook (without saving or warnings) after the copy so I would suggest that you loop through the columns you do not want and delete then prior to the copy. Incorporate this snippet into your existing code
Dim v As Long, vNoCopy As Variant, wb As Workbook
vNoCopy = Array(1, 3, 5, 7) 'should in ascending order (reversed below)
With wb.Sheets("Report")
.Cells = .Cells.Value 'just in case there are referenced formulas involved
For v = UBound(vNoCopy) To LBound(vNoCopy) Step -1
.Columns(vNoCopy(v)).EntireColumn.Delete
Next v
wb.Sheets("Report").Copy After:=activeWB.Sheets(activeWB.Sheets.Count)
End With
wb.Close False
That should remove columns A, C, E & G from the report before copying. Closing without saving should leave the original Report.xlsx unaffected.
I am trying to select a worksheet every time when i open up a workbook using an inputbox in VBA. here is my code for opening a workbook but after i open up my workbook, how do i select a worksheet inside that workbook?
Sub button7_click()
dim wb as string
dim ss as string
wb = Application.GetOpenFilename
if wb <> "False" Then Workbooks.Open wb
End sub
Assuming "Sheet1" is the name of the sheet that you want to select...
Workbooks(wb).Sheets("Sheet1").Select
EDIT: And you can use something like this to get a variable sheet name from an InputBox. In its simplest form...
Dim Result As String
Result = InputBox("Provide a sheet name.")
Workbooks(wb).Sheets(Result).Select
...but I would add some error handling into this also to prevent errors from blanks, misspelled or invalid sheet names.
Let's say you have a "normal", blank Excel workbook with sheets "Sheet1", "Sheet2" and "Sheet3". Now, when the workbook opens, let's assume you want to activate (not select, as that's different) the sheet called "Sheet2".
In your workbook's ThisWorkbook module, add this code:
Private Sub Workbook_Open()
ActiveWorkbook.Sheets("Sheet2").Activate
End Sub
Make sure this code is pasted inside of the ThisWorkbook object and not in a Module, Form, or Sheet object.
Save and exit the workbook. When you re-open it, "Sheet2" will be the active sheet.
Here is the final code if anyone wants it.
Multiple selections are not quite possible , as the copied worksheet only copies across and increments the largest value of the range selected rather than all the cells selected individually ....
Sub CopyAndIncrement()
Dim ws As Worksheet
Dim Count As Integer
Dim Rng As Range
Dim myValue As Integer
Dim wsName As String
wsName = InputBox("Provide the EXACT sheet name you want to copy.")
'error handling loop for Worksheet name
For p = 1 To Worksheets.Count
If Worksheets(p).Name = wsName Then
exists = True
End If
Next p
If Not exists Then
While exists = False
wsName = InputBox("Sheet not found re-enter name.")
For p = 1 To Worksheets.Count
If Worksheets(p).Name = wsName Then
exists = True
End If
Next p
Wend
End If
Set Rng = Application.InputBox( _
Title:="Increment your worksheet", _
Prompt:="Select a cell(s) you want to increment", _
Type:=8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub 'Test to ensure User Did not cancel
'Set Rng = Rng.Cells(1, 1) 'Set Variable to first cell in user's input (ensuring only
'1 cell) >> commenting this can give multiple selections
myValue = InputBox("How many time do you want it to increment? Give me the number ")
Do While Count < myValue
For Each ws In Worksheets ' this loop selects the last sheet in the workbook
LastWs = ws.Name
i = ws.Range(Rng.Address).Value
If i > j Then
j = i
End If
Next
Sheets(wsName).Select
Sheets(wsName).Copy After:=Sheets(LastWs)
ActiveSheet.Range(Rng.Address).Value = j + 1
Count = Count + 1
Loop
End Sub
I am trying to loop through some columns in a row and create new worksheets with the name of the value of the current column/row that I am in.
Sub test()
Range("R5").Select
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End Sub
This code creates the first one correctly starting at R5 but then it appears that the macro switches to that worksheet and doesn't complete the task.
The Sheets.Add automatically moves your selection to the newly created sheet (just like if you insert a new sheet by hand). In consequence the Offset is based on cell A1 of the new sheet which now has become your selection - you select an empty cell (as the sheet is empty) and the loop terminates.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set MyNames = Range("R5").CurrentRegion ' load contigeous range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell children of range variable
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
This will work better .... you assign the list of names to an object variable of type Range and work this off in a For Each loop. After you finish you put your Selection back to where you came from.
Sheets.Add will automatically make your new sheet the active sheet. Your best bet is to declare variables to your objects (this is always best practice) and reference them. See like I've done below:
Sub test()
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
Dim rng As Range
Set rng = .Range("R5")
Do Until IsEmpty(rng)
Sheets.Add.Name = rng.Value
Set rng = rng.Offset(0, 1)
Loop
End With
End Sub
Error handling should always be used when naming sheets from a list to handle
invalid characters in sheet names
sheet names that are too long
duplicate sheet names
Pls change Sheets("Title") to match the sheet name (or position) of your title sheet
The code below uses a variant array rather than a range for the sheet name for performance reasons, although turning off ScreenUpdating is likely to make the biggest difference to the user
Sub SheetAdd()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strError As String
Dim vArr()
Dim lngCnt As Long
Dim lngCalc As Long
Set ws1 = Sheets("Title")
vArr = ws1.Range(ws1.[r5], ws1.[r5].End(xltoRight))
If UBound(vArr) = Rows.Count - 5 Then
MsgBox "sheet range for titles appears to be empty"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
For lngCnt = 1 To UBound(vArr)
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = vArr(lngCnt, 1)
If Err.Number <> 0 Then strError = strError & vArr(lngCnt, 1) & vbNewLine
On Error GoTo 0
Next lngCnt
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Len(strError) > 0 Then MsgBox strError, vbCritical, "These potential sheet names were invalid"
End Sub
This is probably the simplest. No error-handling, just a one-time code to create sheets
Sub test()
Workbooks("Book1").Sheets("Sheet1").Range("A1").Activate
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
Workbooks("Book1").Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Select
Loop
End Sub