Option Explicit
Sub DifferenceBetweenEngineersAndArchitects()
'
' constants
Const ksWSSource = ",Projects,Small Works,Tech & Crate,Tech Only"
Const ksWSTarget = ",All,Scheduled,Completed,Progress"
Const ksWBTarget = "JLL MAC DATA FILE - #.xlsx"
Const kiFilter = 16
Const ksCriteria = ",,SCHEDULED,COMPLETED,"
'
' declarations
Dim wbSrc As Workbook, wbTgt As Workbook
Dim sSrc() As String, sTgt() As String, sCriteria() As String
Dim iSrc() As Integer, iTgt() As Integer
Dim bSrc() As Boolean
Dim I As Integer, J As Integer, b As Boolean, bSave As Boolean, A As String
'
' start
' arrays
sSrc = Split(ksWSSource, ",")
sTgt = Split(ksWSTarget, ",")
sCriteria = Split(ksCriteria, ",")
ReDim iSrc(UBound(sSrc))
ReDim iTgt(UBound(sTgt))
' wbs
' source
Set wbSrc = ThisWorkbook
With wbSrc
.Activate
bSave = .Saved
End With
' target
Workbooks.Add
A = Replace(ksWBTarget, "#", Format(Now(), "yyyy-mm-dd hh.mm.ss"))
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & A
Set wbTgt = ActiveWorkbook
With wbTgt
For I = 1 To UBound(sTgt)
If I > .Worksheets.Count Then .Worksheets.Add , .Worksheets(.Worksheets.Count)
.Worksheets(I).Name = sTgt(I)
Next I
End With
' titles
For I = 1 To UBound(sTgt)
iTgt(I) = 1
With wbTgt.Worksheets(sTgt(I))
.Cells.Clear
wbSrc.Worksheets(sSrc(1)).Rows(1).Copy .Rows(1)
End With
Next I
' hidden cols - part I (aka six-pack of Carlsberg)
With wbSrc
.Activate
I = .Worksheets(sSrc(1)).[A1].End(xlToRight).Column
ReDim bSrc(UBound(sSrc), I)
For I = 1 To UBound(sSrc)
' existent sheet
If Not WorksheetFunction.IsErr(Evaluate("'" & sSrc(I) & "'!A1")) Then
With .Worksheets(sSrc(I))
For J = 1 To UBound(bSrc, 2)
bSrc(I, J) = .Columns(J).Hidden
.Columns(J).Hidden = False
Next J
End With
End If
Next I
End With
'
' process
wbSrc.Activate
For I = 1 To UBound(sSrc)
' existent sheet
If Not WorksheetFunction.IsErr(Evaluate("'" & sSrc(I) & "'!A1")) Then
' copy all to all
CopyingFilteredRows wbTgt, sTgt(1), sSrc(I), 0, "*", "*"
' copy scheduled to scheduled
CopyingFilteredRows wbTgt, sTgt(2), sSrc(I), kiFilter, sCriteria(2), sCriteria(2)
' copy completed to completed
CopyingFilteredRows wbTgt, sTgt(3), sSrc(I), kiFilter, sCriteria(3), sCriteria(3)
' copy no scheduled & no completed to progress
CopyingFilteredRows wbTgt, sTgt(4), sSrc(I), kiFilter, "<>" & sCriteria(2), "<>" & sCriteria(3)
Else
MsgBox "Unable to find worksheet " & sSrc(I), vbOKOnly + vbCritical, "Warning"
End If
Next I
'
' end
' hidden cols - part II (aka another six-pack of Carlsberg)... or...
With wbSrc
For I = 1 To UBound(sSrc)
' existent sheet
If Not WorksheetFunction.IsErr(Evaluate("'" & sSrc(I) & "'!A1")) Then
With .Worksheets(sSrc(I))
For J = 1 To UBound(bSrc, 2)
.Columns(J).Hidden = bSrc(I, J)
Next J
End With
End If
Next I
End With
' save & reposition
wbSrc.Saved = bSave
wbTgt.Save
' beep (thanks to Marc L at chandoo.org)
MarcLBeepDemo
MsgBox "Workbook has been created: " & A, vbInformation + vbOKOnly, "End process"
' wbs
Set wbSrc = Nothing
Set wbTgt = Nothing
'
End Sub
Private Sub CopyingFilteredRows(pwbTgt As Workbook, psTgt As String, psSrc As String, _
piFilter As Integer, psCriteria1 As String, psCriteria2 As String)
' constants
' declarations
Dim lRow As Long
' start
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' process
With Worksheets(psSrc)
lRow = Worksheets(psTgt).[A1].End(xlDown).End(xlDown).End(xlUp).Row
If piFilter > 0 Then .Cells.AutoFilter Field:=piFilter, Criteria1:=psCriteria1, Operator:=xlAnd, Criteria2:=psCriteria2
If .[A1].Offset(1, 0).Value <> "" And .[A1].Offset(1, 0).End(xlDown).Value <> "" Then _
Range(.[A1].Offset(1, 0).EntireRow, .[A1].Offset(1, 0).End(xlDown).EntireRow).Copy pwbTgt.Worksheets(psTgt).Rows(lRow + 1)
If piFilter > 0 Then .ShowAllData
End With
' end
With Application
.CutCopyMode = False
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub