(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
Related
I have a report I receive once a week with multiple data blocks that have dynamic rows and columns and each data block has a static title that will never change that are separated by a blank row. I am trying to copy these blocks into sheets based off of these titles.
I have a script that is creating the sheets and blank rows between data blocks with Python. But I am hoping to do the rest with VBA. Here is the end result Example.
Currently each of those sheets are blank, and I want to either copy paste or cut and paste the blocks into those sheets without their titles. i.e. A41:C46 into the Unanswered Service Level sheet.
Sub FormatExcel()
Dim LR As Long, i As Long
With Sheets("Master")
LR = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
With .Range("A" & i)
If .Value = "All Call Distribution by Queue" Then
ActiveCell.CurrentRegion.Select
Selection.Copy
Sheets("All Calls by Queue").Select
ActiveSheet.Paste
End If
End With
Next
End With
End Sub
This is what I have so far.
It will copy/paste into the designated sheet. But I'm stuck on why it's adding a second blank row at the top and how to code it so that if the sheet doesn't exist then nothing will happen. I am very new to VBA but I pieced this together from other code and just recording macros. Otherwise I was just going to copy and paste this code 15 times just with different sheet titles and .Values
You can use an approach like this:
Sub FormatExcel()
Dim ws As Worksheet, wb As Workbook
Set wb = ThisWorkbook 'ActiveWorkbook?
Set ws = wb.Worksheets("Master")
CopyBlock ws, "All Call Distribution by Queue", "All Calls by Queue"
CopyBlock ws, "Title2", "Title2 sheet"
'etc etc
End Sub
Sub CopyBlock(ws As Worksheet, title As String, destWS As String)
Dim f As Range, rng As Range, wsDest As Worksheet
'check if destination worksheet is present
On Error Resume Next 'ignore any error
Set wsDest = ws.Parent.Worksheets(destWS) 'check in same workbook as `ws`
On Error GoTo 0 'stop ignoring errors
If wsDest Is Nothing Then
Debug.Print "Missing sheet '" & destWS; "' in workbook '" & ws.Parent.Name & "'"
Exit Sub
End If
Set f = ws.Columns("A").Find(what:=title, lookat:=xlWhole) 'search header
If Not f Is Nothing Then 'got a match?
Set rng = f.CurrentRegion
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1) 'exclude header row
rng.Copy wsDest.Range("A1") 'copy to specific location
End If
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
In the MasterSheet say I have column headers "Employee Names", "CarType" and "DOB". These columns and their row data are found in different sheets in the same workbook. I need a simple lookup function in VBA to search for multiple column headers and COPY over the entire column. I need multiple columns in the master file to be filled in like this so a loop function is needed.
If a heading is not found leave the row blank and move on to the column header on the MasterSheet.
Thank you in advance! My first post and so I don't know if the explanation above helps.
Sample MasterSheet
Sheet2 where one column head is
The below basic code is what I found but it's too basic and doesn't loop through
Macro VBA to Copy Column based on Header and Paste into another Sheet
This is what I have so far but the limitations are that it looks at one sheet at a time and the header search is not dynamic.
Sub MasterSheet()
Dim newSht As Worksheet, sSht As Worksheet, Hdrs As Variant, i As Long, EdrisRange As
Range
Set sSht = ActiveSheet
'Expand the array below to include all relevant column headers - I want the below
line to be dynamic. Looking at multiple headers from the MasterSheet.
Hdrs = Array("Heading 1")
Application.ScreenUpdating = False
Set newSht = Worksheets.Add(after:=sSht)
With sSht.UsedRange.Rows(1)
For i = LBound(Hdrs) To UBound(Hdrs)
Set EdrisRange = .Find(Hdrs(i), lookat:=xlWhole)
If Not EdrisRange Is Nothing Then
Intersect(EdrisRange.EntireColumn, sSht.UsedRange).Copy
Destination:=newSht.Cells(1, i + 1)
End If
Next i
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub
Something like this should work:
Sub MasterSheet()
Dim wb As Workbook
Dim newSht As Worksheet, Hdrs As Variant, i As Long, EdrisRange As Range
Hdrs = Array("Heading 1", "Heading 2")
Set wb = ActiveWorkbook
Set newSht = wb.Worksheets.Add(after:=ActiveSheet)
For i = LBound(Hdrs) To UBound(Hdrs)
Set EdrisRange = FindHeaderInWorkbook(wb, CStr(Hdrs(i)), newSht)
If Not EdrisRange Is Nothing Then
Application.Intersect(EdrisRange.EntireColumn, EdrisRange.Parent.UsedRange).Copy _
Destination:=newSht.Cells(1, i + 1)
End If
Next i
Application.CutCopyMode = False
End Sub
'find a header *HeaderText* in a workbook *wb*, excluding the sheet *excludeSheet*
Function FindHeaderInWorkbook(wb As Workbook, HeaderText As String, excludeSheet As Worksheet)
Dim sht As Worksheet, rng As Range
For Each sht In wb.Worksheets
If sht.Name <> excludeSheet.Name Then
Set rng = sht.Rows(1).Find(what:=HeaderText, lookat:=xlWhole)
If Not rng Is Nothing Then Exit For
End If
Next sht
Set FindHeaderInWorkbook = rng
End Function
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
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