In the code below, we can put Sheet1 - Sheet4 in selection mode and copy.
But the point here is that the number of Sheets varies. Each time the file is changed, the number of Sheets is low or high. I just want to copy Sheet1 .... n, not all Sheets. (Every Sheet with the name of the "Sheet".
How can this code be corrected for this issue?
Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
Sub m()
Dim nSht As Long
ReDim shts(1 To Worksheets.Count) As String
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name Like "Sheet*" Then
nSht = nSht + 1
shts(nSht) = sht.Name
End If
Next
If nSht > 0 Then
ReDim Preserve shts(1 To nSht)
Worksheets(shts).Copy
End If
just for the record, here's the first solution spoiling
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name Like "Sheet*" Then
If Not ActiveSheet.Name Like "Sheet*" Then sht.Activate
sht.Select False
End If
Next
ThisWorkbook.Windows(1).SelectedSheets.Copy
Related
I am trying to create a consolidated list of highlighted cells that are on different tabs in my workbook. As I understand VBA is my best option.
Logic would be something like:
Loop through all tabs and
If cell = color index 4 then
copy value and paste into a tab called 'highlightedcells'
Im as far as this currently
sub findhighlights
For Each ws In ActiveWorkbook.Worksheets
For Each Cell In ws.UsedRange.Cells
If Cell.Interior.ColorIndex = 4 Then
cell.value.copy
Any help would be welcomed.
Try this out:
Sub findhighlights()
Dim wb As Workbook, ws As Worksheet, c As Range, wsList As Worksheet
Set wb = ActiveWorkbook 'always use a specific workbook
Set wsList = wb.Worksheets("Listing") 'listing goes here
For Each ws In wb.Worksheets 'loop sheets
If ws.Name <> wsList.Name Then 'skip the "Listing" sheet
For Each c In ws.UsedRange.Cells
If c.Interior.ColorIndex = 4 Then
'list info for this cell
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Resize(1, 3).Value = Array(ws.Name, c.Address, c.Value)
End With
End If
Next c
End If 'is not the Listing sheet
Next ws
End Sub
I have a 52 sheet workbook that needs to be reset after the file is saved as a copy.
I have the UnHide part figured out, but I can't seem to figure out the Clearcontents.
On many Worksheets, not all, in row A there is a string "State Requires All License Verifications"
It is in a variable row, between 6 and 12. Starting with ws2 I want to find the string and clear the rows below it. Column range A:H
Then Check the next worksheet.
I have this so far..
Sub UnhideAllSheets()
Dim ws As Worksheet
Dim rowNum As Long
Dim stateReg As String
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
If ws.Visible Then
'Activate sheet
ws.Activate
'Look for String "State Requires All License Verifications"
Set stateReq = .Find(what:="State Requires All License Verifications")
'Null find quits loop
If Not stateReq Is Nothing Then
rowNum = stateReq.Row
End If
'Clear all Used rows after String(stateReq)
With Sheets(ws)
Intersect(.Range(.Rows(rowNum + 1), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("A:H")).ClearContents
End With
'Select and Zoom to A1 upon leaving the worksheet
Range("A1").Select
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
End If
Next ws
'Jump back to the first worksheet "Information"
Sheets("Information").Select
Range("E2").Select
End Sub
Try this. Not sure where you got stuck.
I have assumed the string is in column A and that A is also a reliable indicator of the last used row (so may need changing).
Also no need to activate the sheet.
Sub UnhideAllSheets()
Dim ws As Worksheet
Dim rowNum As Long
Dim stateReg As Range
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Set stateReg = ws.Columns(1).Find(what:="State Requires All License Verifications", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not stateReg Is Nothing Then
Range(stateReg.Offset(1), ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 8).ClearContents
End If
Next ws
'Jump back to the first worksheet "Information"
Application.Goto Sheets("Information").Range("E2")
End Sub
Maybe something like:
Sub Fresh_Slate()
Dim ws As Worksheet
Dim Found As Range
Dim Target As String
Dim lr As Long
Target = "State Requires All License Verifications"
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Sheet1" Then 'You can add sheets to ignore here
ws.Visible = xlSheetVisible
Set Found = ws.Cells.Find(Target)
If Not Found Is Nothing Then
'Assuming Column A on each sheet is a good indicator of the last used row in range
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range(ws.Cells(Found.Row + 1, 1), ws.Cells(lr, 8)).ClearContents
End If
Set Found = Nothing
End If
Next ws
End Sub
I have this code where it loops through all the sheets in the workbook and copies the value in F9 of each sheet and pastes it in "Summary" sheet column A. How can I also print the sheet name in column B? So the value is next to the sheet name in the "Summary" sheet.
code:
Sub loopsheet()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If Not wks.Name = "Summary" Then
wks.Range("F9:F" & wks.Cells(Rows.Count, "F").End(xlUp).Row).Copy _
Destination:=Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next
End Sub
Thank you
Create two variables to track the last rows of your sheets as you loop. This will help with readability in your code. The combination of these two variables can also help you deduce the size of the range where you need to drop your sheet name.
I believe cLR + pLR - 11 is the size of range. The offset is due to headers, LR offset, and the fact that you are starting your copy from the 9th row. After you run this, you may need to tweak it up or down one if i'm wrong.
Option Explicit
Sub LoopSheet()
Dim ws As Worksheet
Dim Summary As Worksheet: Set Summary = ThisWorkbook.Sheets("Summary")
Dim cLR As Long, pLR As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> Summary.Name Then
cLR = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
pLR = Summary.Range("A" & Summary.Rows.Count).End(xlUp).Offset(1).Row
ws.Range("F9:F" & cLR).Copy Summary.Range("A" & pLR)
Summary.Range(Summary.Cells(pLR, 2), Summary.Cells(cLR + pLR - 11, 2)).Value = ws.Name
End If
Next ws
End Sub
(1) I´d appreciate if somebody could help me briefly. I can not really figure out how to include the formula "entire row" into the code below, so that the macro copies from min to max in column F but also the entire row of each data point...
Sub Enter_Formula()
Dim sht As Worksheet, summarySht As Worksheet
Set summarySht = Worksheets("SummarySheet") '<--| change "Summary" to your actual "Summary" sheet name
For Each sht In Worksheets
If sht.Name <> summarySht.Name Then
With sht.Range("F15000:F20000")
.Parent.Range(.Find(what:=WorksheetFunction.Min(.Cells), lookat:=xlWhole, LookIn:=xlValues), .EntireColumn.Find(what:=WorksheetFunction.Max(.EntireColumn), lookat:=xlWhole, LookIn:=xlValues)).Copy summarySht.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
End With
End If
Next
End Sub
(2) The other question is, how to modify the code, so that excel creates an extra "summary" sheet for each sheet the macro runs over. I do not want one summarysheet for all the found ranges because that is too confusing for the reader.
Thank you very much!
Try this (not sure you really need to copy the whole row though do you?) The summary sheet name is just the sheet name preceded by "Summary".
Sub x()
Dim sht As Worksheet, summarySht As Worksheet
Dim rMin As Range, rMax As Range
For Each sht In Worksheets
If Not sht.Name Like "Summary*" Then
Set summarySht = Sheets.Add(after:=Sheets(Sheets.Count))
summarySht.Name = "Summary " & sht.Name
With sht.Range("F15000:F20000")
Set rMin = .Find(what:=WorksheetFunction.Min(.Cells), lookat:=xlWhole, LookIn:=xlValues)
Set rMax = .EntireColumn.Find(what:=WorksheetFunction.Max(.EntireColumn))
.Parent.Range(rMin, rMax).EntireRow.Copy summarySht.Range("A1")
End With
End If
Next sht
End Sub
I have three separate worksheets in a workbook that contain thousands of rows of information and new information is added frequently. I would like to be able to create separate reports using macros and VBA to print onto another worksheet when I need the report.
For example, report one would include all completed jobs in 2014. If Completed? equals YES and Year equals 2014, print entire row on blank worksheet. However, I need to use VBA so it goes through three worksheets and prints them all together in a separate worksheet. How would I do this?
Clarification: Basically if these two cells equal this and this, print the row on a different sheet.
Practice with this.
Insert a button or some other type of object on the sheet with the data.
Once clicked the code will delete all the sheets except the active sheet.
It then loops through column A and creates the sheets.
Then it loops through the sheets and filters your data sheet, copies and pastes the data into the sheet and moves on to the next sheet.
Sub getSht()
Dim c As Range, sh As Worksheet
Dim Rws As Long, Rng As Range, fRng As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Application.DisplayAlerts = 0
Application.ScreenUpdating = 0
For Each sh In Sheets
If sh.Name <> ws.Name Then sh.Delete
Next sh
With ws
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(Rws, 1))
For Each c In Rng.Cells
If WorksheetExists(c.Value) Then
Else: Sheets.Add.Name = c
End If
Next c
End With
For Each sh In Sheets
If sh.Name <> ws.Name Then
ws.Range("A:A").AutoFilter Field:=1, Criteria1:=sh.Name
Set fRng = ws.Range(ws.Cells(1, "A"), ws.Cells(Rws, "D"))
fRng.Copy Destination:=sh.Range("A1")
End If
ws.AutoFilterMode = 0
Next sh
ws.Activate
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function