Option Explicit
Sub AWS_Report()
' No visible changes until complete
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
ActiveWindow.DisplayHeadings = True
' Assign Ranges
Dim Report, Data, Lists As Worksheet
Dim ReportR, ReportR1, ReportR2, ReportR3 As Integer
Dim ReportR4, ReportR5, ReportR6, ReportR7, ReportR8 As Integer
Dim ReportC, ReportC1, ReportC2, ReportC3 As Integer
Dim ReportC4, ReportC5, ReportC6, ReportC7, ReportC8 As Integer
Dim DataR, DataR1, DataR2, DataR3 As Integer
Dim DataR4, DataR5, DataR6, DataR7, DataR8 As Integer
Dim DataC, DataC1, DataC2, DataC3 As Integer
Dim DataC4, DataC5, DataC6, DataC7, DataC8 As Integer
Dim ListsR, ListsR1, ListsR2, ListsR3 As Integer
Dim ListsC, ListsC1, ListsC2, ListsC3 As Integer
Dim x As Integer
Dim Location, Choice, Text As Variant
Dim Orig_Data, Site_Data, Change_Order, Action_Items, Site_Contacts, NameX As Name
Dim Fence_Contacts As Name
' Set Workbooks and Original Name Ranges
Set Report = Sheets("Report")
Set Data = Sheets("Data")
Set Lists = Sheets("Lists")
' Clear Report
Sheets("Report").Select
Cells.Clear
On Error Resume Next
ActiveSheet.Shapes.Range(Array("logo")).Select
Selection.Delete
On Error GoTo 0
' ActiveSheet.Shapes.Range(Array("logo")).Delete
' Selection.Delete Sheets("Data").Select
' Delete Named Ranges
On Error Resume Next
ActiveWorkbook.Names("Orig_Data").Delete
ActiveWorkbook.Names("Site_Contacts").Delete
ActiveWorkbook.Names("Fence_Contacts").Delete
ActiveWorkbook.Names("Action_Items").Delete
ActiveWorkbook.Names("Location").Delete
ActiveWorkbook.Names("Orig_Data").Delete
ActiveWorkbook.Names("Site_Data").Delete
On Error GoTo 0
' Set Title Range
DataC = Data.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
DataR = Data.Cells(Rows.Count, "A").End(xlUp).Row
' Copy Data to Report
Data.Select
Data.Range("A1", Cells(DataR, DataC)).Name = "Orig_Data"
Range("Orig_Data").Copy
With Report.Range("A1")
.PasteSpecial (xlPasteColumnWidths)
.PasteSpecial (xlPasteValues)
.PasteSpecial (xlFormats)
End With
Data.Select
ActiveSheet.Shapes.Range(Array("logo")).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
Range("J4").Select
ActiveSheet.Paste
Report.Select
ReportC = Data.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
' Set Site Range
ReportR1 = Report.Cells.Find(What:="Sites", SearchDirection:=xlNext, SearchOrder:=xlByRows).Row + 3
ReportR2 = Report.Cells.Find(What:="Fence Projects", SearchDirection:=xlNext, SearchOrder:=xlByRows).Row - 1
ReportC1 = Report.Cells.Find(What:="AWS CEll #", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Report.Range(Cells(ReportR1, 1), Cells(ReportR2, ReportC1)).Name = "Site_Contacts"
' Set Fence Range
ReportR3 = Report.Cells.Find(What:="Fence Projects", SearchDirection:=xlNext, SearchOrder:=xlByRows).Row + 1
ReportR4 = Report.Cells.Find(What:="Action Items", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - 2
Report.Range(Cells(ReportR3, 1), Cells(ReportR4, ReportC1)).Name = "Fence_Contacts"
' Set Action Items Range
ReportR5 = Report.Cells.Find(What:="Action Items", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 3
ReportR6 = Report.Cells.Find(What:="Change Orders", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - 2
Report.Range(Cells(ReportR5, 1), Cells(ReportR6, ReportC)).Name = "Action_Items"
' Set Change Order Range
ReportC2 = Report.Cells.Find(What:="Date Requested", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
ReportR7 = Report.Cells.Find(What:="Change Orders", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 3
ReportR8 = Report.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Report.Range(Cells(ReportR7, 1), Cells(ReportR8, ReportC2)).Name = "Change_Order"
' Set Location
With Report.Range("C8:H8")
.Name = "Location"
.ClearContents
End With
Report.Range("Location").Select
With Selection.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Sites"
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Range("Location").Value = "All Sites"
' Select Rows to Keep
Choice = InputBox("Enter Site Location", Text)
Report.Range("Location").Cells(1).Value = Choice
ReportR1 = Report.Cells.Find(What:="Sites", SearchDirection:=xlNext, SearchOrder:=xlByRows).Row + 3
ReportR2 = Report.Cells.Find(What:="Fence Projects", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - 2
If Choice <> "All Sites" Then
For x = ReportR1 To ReportR2
If Report.Cells(x, 1).Value <> "Fence Projects" And Report.Cells(x, 1).Value <> Choice Then
Report.Cells(x, 1).EntireRow.Delete
ReportR2 = ReportR2 - 1
x = x - 1
ElseIf Report.Cells(x, 1).Value = "Fence Projects" Then GoTo 1
End If
Next x
1 End If
ReportR3 = Report.Cells.Find(What:="Fence Projects", SearchDirection:=xlNext, SearchOrder:=xlByRows).Row + 1
ReportR4 = Report.Cells.Find(What:="Action Items", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - 2
If Choice <> "All Sites" Then
For x = ReportR3 To ReportR4
If Report.Cells(x, 1).Value <> "Action Items" And Report.Cells(x, 1).Value <> Choice Then
Report.Cells(x, 1).EntireRow.Delete
ReportR4 = ReportR4 - 1
x = x - 1
ElseIf Report.Cells(x, 1).Value = "Action Items" Then GoTo 2
End If
Next x
2 End If
ReportR5 = Report.Cells.Find(What:="Action Items", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 3
ReportR6 = Report.Cells.Find(What:="Change Orders", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - 2
If Choice <> "All Sites" Then
For x = ReportR5 To ReportR6
If Report.Cells(x, 1).Value <> "Change Orders" And Report.Cells(x, 2).Value <> Choice Then
Report.Cells(x, 1).EntireRow.Delete
ReportR6 = ReportR6 - 1
x = x - 1
ElseIf Report.Cells(x, 1).Value = "Change Orders" Then GoTo 3
End If
Next x
3 End If
ReportR7 = Report.Cells.Find(What:="Change Orders", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 3
ReportR8 = Report.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If Choice <> "All Sites" Then
For x = ReportR7 To ReportR8
If Report.Cells(x, 1).Value <> "End" And Report.Cells(x, 2).Value <> Choice Then
Report.Cells(x, 1).EntireRow.Delete
ReportR8 = ReportR8 - 1
x = x - 1
ElseIf Report.Cells(x, 1).Value = "End" Then GoTo 4
End If
Next x
4 End If
ReportR7 = Report.Cells.Find(What:="Change Orders", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 3
ReportR8 = Report.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Report.Range(Cells(ReportR7, 1), Cells(ReportR8 - 1, ReportC2)).Name = "Change_Order"
With Report.Range("Change_Order")
.Borders.Weight = xlMedium
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
End Sub
Dim ReportR, ReportR1, ReportR2, ReportR3 As Integer
ElseIf Report.Cells(x, 1).Value = "Fence Projects" Then GoTo 1
doElseIf Report.Cells(x, 1).Value = "Fence Projects" Then Exit For
ActiveSheet.Shapes("logo").Select
Site A
Site B
Site C
Site D
I'm using this as a reference to delete all rows that don't match from a very large report. This will make the report easier to read with only specific sites data.
The above is a named list "Sites"
Open in new window
Hope this helps