Sub CopyFieldworkReports()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'variables only for t(ango)his workbook
Dim C4Workbook As Workbook 'tango1
Dim myPath As String 'tango2
Dim myFile As String 'tango3
Dim myExtension As String 'tango4
Dim FldrPicker As FileDialog 'tango5
Dim SheetOfOpenBook As Worksheet 'tango6
Dim FirstOfValidVersions As Long 'tango7
Dim i As Long 'tango8
Dim j As Long
Dim C4LastRow As Long 'tango9
Dim P2LastRow As Long 'tango10
Dim C4Range As Range 'tango11
Dim C4FirstColumn As Variant 'tango12
Dim P2Range As Range 'tango13
Dim NumberDataRows As Long 'tango14
Dim ws As Worksheet 'tango15
Dim LastRowBooksCopied As Long 'tango17
Dim FirstSheetOfCompilation As Variant 'tango18
Dim ColumnNamesOfFilesCopied As Variant 'tango19
Dim LastRowNotCopiedCntrAltDelete As Long 'tango20
Dim ColumnNamesNotCopiedCntrAltDelete As Variant 'tango21
Dim CounterFirstSheetPresent As Long 'tango16
Dim CounterFirstSheetActive As Long 'tango22
Dim CounterYear As Long 'tango23
Dim CounterVersion As Long 'tango24
Dim LastRowNotCopiedForeign As Long 'tango25
Dim ColumnNamesNotCopiedForeign As Variant 'tango26
Dim LastHeadingRowOnCompilation As Long 'tango27
Dim CounterMemberInfo As Long 'tango28
Dim LastRowNotCopiedMemberInfo As Long 'tango29
Dim ColumnNamesNotCopiedMemberInfo As Variant 'tango30
Dim LastRowNotCopiedVersion As Long 'tango31
Dim ColumnNamesNotCopiedVersion As Variant 'tango32
Dim LastRowNotCopiedVersionAndMemberInfo As Long 'tango33
Dim ColumnNamesNotCopiedVersionAndMemberInfo As Variant 'tango34
Dim SubmissionSheetName As Variant 'tango35
Dim LastRowSubmissionSheet As Long 'tango36
'First sheet variables as on 2020-05-06: FIELDWORKARRAYS, Module: RunTool (Fieldwork) and Thisworkbook (Fieldwork).
Dim NameOfFirstSheet As Variant 'bravo1
Dim CellNameOfProvinceOnFirstSheet As Variant 'bravo2
Dim CellNameOfRegionOrDivisionOnFirstSheet As Variant 'bravo3
Dim CellReportingMonthOnFirstSheet As Variant 'bravo4
Dim CellMembersEmailOnFirstSheet As Variant 'bravo5
Dim CellMembersPhoneOnFirstSheet As Variant 'bravo6
Dim CellProfessionOnFirstSheet As Variant 'bravo7
Dim CellMemberNameOnFirstSheet As Variant 'bravo8
Dim CellMemberRankOnFirstSheet As Variant 'bravo9
Dim CellCommanderEmailOnFirstSheet As Variant 'bravo10
Dim CellReasonForNotSubmittingOnFirstSheet As Variant 'bravo11
Dim CellPERSALonFirstSheet As Variant 'bravo12
Dim CellMemberStationOnFirstSheet As Variant 'bravo13
'variable names of first sheet of fieldwork, only used in compilation COMPILATIONARRAYS, Module: CopyFieldworkReports.
'As on 2020-06-02
Dim CellFinancialYearOnFieldwork As Variant 'charlie1
Dim CellFieldworkVersion As Variant 'charlie2
Dim ThisFinancialYear As Variant 'charlie3
Dim CompulsoryCellsMemberInfo As Variant 'charlie4
Dim CompulsoryCellsMemberInfoRange As Variant 'charlie5
Dim CellPsycCategory As Variant 'charlie6
'Variables definition for Copy and Paste as on 2020-05-22:COMPILATIONARRAYS
Dim NameOfSheet As Variant 'alfa1
Dim C4LastColumn As Variant 'delta1
Dim C4LastRowHeading As Variant 'delta2
Dim P2ColumnStart As Variant 'delta3
Dim P2ColumnEnd As Variant 'delta4
'arrays of bravos and charlies as on 2020-06-04. COMPILATIONARRAYS
Dim CellsOnFieldworkFirstSheet As Variant 'hotel1
Dim ColumnsOnCompileSubmission As Variant 'hotel2
'----------------------------------------
'change only these varaibles
'----------------------------------------
'variables only for this module
FirstOfValidVersions = 1 'tango7, the version number on the fieldwork report
C4FirstColumn = "A" 'tango12, the first column in fieldwork where copy will start
FirstSheetOfCompilation = "Compile" 'tango18
ColumnNamesOfFilesCopied = "B" 'tango19, feedback for user on the first sheet of compilation report
ColumnNamesNotCopiedCntrAltDelete = "C" 'tango21, feedback for user on the first sheet of compilation report
ColumnNamesNotCopiedForeign = "G" 'tango26, feedback for user on the first sheet of compilation report
LastHeadingRowOnCompilation = 14 'tango27, heading row of feedback on first sheet of compilation report
ColumnNamesNotCopiedMemberInfo = "D" 'tango30
ColumnNamesNotCopiedVersion = "E" 'tango32
ColumnNamesNotCopiedVersionAndMemberInfo = "F" 'tango34
SubmissionSheetName = "Submission" 'tango35
'Copied from fieldwork report 2020-05-17
'First sheet values as on 2020-05-06: FIELDWORKARRAYS, Modules: RunTool (Fieldwork) and Thisworkbook (Fieldwork).
NameOfFirstSheet = "EhwMemberInfo" 'bravo1
CellNameOfProvinceOnFirstSheet = "C11" 'bravo2
CellNameOfRegionOrDivisionOnFirstSheet = "C12" 'bravo3
CellReportingMonthOnFirstSheet = "C18" 'bravo4
CellMembersEmailOnFirstSheet = "C19" 'bravo5
CellMembersPhoneOnFirstSheet = "C20" 'bravo6
CellProfessionOnFirstSheet = "C14" 'bravo7
CellMemberNameOnFirstSheet = "C15" 'bravo8
CellMemberRankOnFirstSheet = "C16" 'bravo9
CellCommanderEmailOnFirstSheet = "C21" 'bravo10
CellReasonForNotSubmittingOnFirstSheet = "D27" 'if applicable, bravo11
CellPERSALonFirstSheet = "C17" 'bravo12
CellMemberStationOnFirstSheet = "C13" 'NHO and Provincial Head Office repeat, bravo13
'variable values of first sheet of fieldwork, only used in compilation COMPILATIONARRAYS. As on 2020-06-02
CellFinancialYearOnFieldwork = "C9" 'charlie1
CellFieldworkVersion = "D9" 'charlie2
ThisFinancialYear = "2020-2021" 'charlie3
CompulsoryCellsMemberInfo = 11 'charlie4
CompulsoryCellsMemberInfoRange = "C11:C21" 'charlie5
CellPsycCategory = "E14" 'charlie6
'Values for Compilation Report as on 2020-06-02: COMPILATIONARRAYS
'alfa1
NameOfSheet = Array("AwarenessProgrammes", "InformationSessions", "Marketing", "SsDevotions", "Groups", "CalendarEvents", "Standby", "Debriefing", "Suicide", "Bereavement", "IllHealth", "Death", "SsPartnerships", "CancelledAwareness", "StationVisits", "Meetings", "Other", "Counselling", "QwCondom", "QwPeerEducation", "QwNumberPeerEducators", "QwVehicleAdaptation", "QwNumberMembersDisability", "QwProcureAssistiveDevices", "QwHealthScreening", "QwWellnessDrives", "SwSupervision", "SwCPD", "SwResearch", "Orphans", "DebriefingTraining", "EntryAssessments", "OD", "SpecialisedSelection", "AssessmentCentre")
'delta1
C4LastColumn = Array("Q", "P", "I", "R", "X", "U", "M", "R", "L", "M", "L", "S", "M", "E", "G", "G", "A", "X", "M", "S", "I", "G", "G", "E", "Y", "S", "B", "D", "F", "N", "H", "H", "I", "D", "F")
'delta2
C4LastRowHeading = Array(3, 3, 3, 2, 3, 3, 2, 2, 3, 3, 2, 3, 3, 2, 2, 2, 1, 2, 4, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 3, 2, 2, 2, 2, 2)
'delta3
P2ColumnStart = Array("C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C", "C")
'delta4
P2ColumnEnd = Array("S", "R", "K", "T", "Z", "W", "O", "T", "N", "O", "N", "U", "O", "G", "I", "I", "C", "Z", "O", "U", "K", "I", "I", "G", "AA", "U", "D", "F", "H", "P", "J", "J", "K", "F", "H")
'arrays of bravos and charlies as on 2020-06-04. COMPILATIONARRAYS.Province,Cluster,Station,Prof,Name,Rank,PERSAL,Month,MemberEmail,MemberPhone,ComEmail,FinYear,Version,PsycCat,NotSubmit
'hotel1
CellsOnFieldworkFirstSheet = Array("C11", "C12", "C13", "C14", "C15", "C16", "C17", "C18", "C19", "C20", "C21", "C9", "D9", "E14", "D27")
'hotel2
ColumnsOnCompileSubmission = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P")
'---------------------------------------
'end of change only these variables
'---------------------------------------
'Retrieve target folder path from user
'(variable reference: FldrPicker tango5)
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
'(variable reference: FldrPicker tango5, myPath tango2)
With FldrPicker
.Title = "Select folder of Fieldwork Reports for this month"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'in case of cancel
'(variable reference: myPath tango2, myPath tango2, myExtension tango4, myFile tango3)
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xls*"
'target path with ending extention
myFile = Dir(myPath & myExtension)
'loop files in folder
'-------------------------------------------------------------------------
'loop through each excel file in folder
Do While myFile <> "" 'myFile tango3
'set variable equal to opened workbook
'(variable reference: C4Workbook tango1, myPath tango2, myFile tango3)
Set C4Workbook = Workbooks.Open(Filename:=myPath & myFile)
'reset counter before conditions
'(variable reference: CounterFirstSheetPresent tango16, CounterFirstSheetActive tango22, CounterYear tango23, CounterVersion tango24)
CounterFirstSheetPresent = 0
CounterFirstSheetActive = 0
CounterYear = 0
CounterVersion = 0
CounterMemberInfo = 0
'if active sheet is the first sheet
'(variable reference number: C4Workbook tango1, NameOfFirstSheet bravo1)
If C4Workbook.ActiveSheet.Name = NameOfFirstSheet Then
CounterFirstSheetActive = CounterFirstSheetActive + 1
End If
'loop each sheet and make it visible
'(variable reference: C4Workbook tango1, SheetOfOpenBook tango6)
With C4Workbook
For Each SheetOfOpenBook In Sheets
SheetOfOpenBook.Visible = True
Next
End With
Do
'loop all sheets in book
'(variable reference: ws tango15)
For Each ws In C4Workbook.Worksheets
'if name of first sheet is present
If ws.Name = NameOfFirstSheet Then
CounterFirstSheetPresent = CounterFirstSheetPresent + 1
'test financial year
If C4Workbook.Sheets(NameOfFirstSheet).Range(CellFinancialYearOnFieldwork).Value = ThisFinancialYear Then
CounterYear = CounterYear + 1
'version
If C4Workbook.Sheets(NameOfFirstSheet).Range(CellFieldworkVersion).Value >= FirstOfValidVersions Then
CounterVersion = CounterVersion + 1
End If
'member info
If WorksheetFunction.CountA(C4Workbook.Sheets(NameOfFirstSheet).Range(CompulsoryCellsMemberInfoRange)) = CompulsoryCellsMemberInfo Then
CounterMemberInfo = CounterMemberInfo + 1
End If
'financial year
End If
'exit sheet loop when first sheet was found, and other items tested
Exit Do
End If
'loop sheets
Next
Loop Until True
'___________________________________________
'start of copy only correct books
'__________________________________________
'copy book if all conditions are met
'1: condition is met, 0: condition is not met
If CounterFirstSheetPresent = 1 And CounterFirstSheetActive = 1 And CounterYear = 1 And CounterVersion = 1 And CounterMemberInfo = 1 Then
'loop sheets
'(variable reference: i tango8,NameOfSheet alfa1, C4LastRow tango9, C4LastRowHeading delta2, P2LastRow tango10, P2ColumnStart delta3)
'(C4Range tango11, C4FirstColumn tango12, C4LastColumn delta1, P2Range tango13, P2ColumnStart delta3, P2ColumnEnd delta4)
'(NumberDataRows tango14)
For i = LBound(NameOfSheet) To UBound(NameOfSheet)
C4LastRow = C4Workbook.Sheets(NameOfSheet(i)).Cells(Rows.Count, C4FirstColumn).End(xlUp).Row
'copy sheet only if there is data
If C4LastRow > C4LastRowHeading(i) Then
'copy data on sheet
P2LastRow = ThisWorkbook.Sheets(NameOfSheet(i)).Cells(Rows.Count, P2ColumnStart(i)).End(xlUp).Row
NumberDataRows = C4LastRow - C4LastRowHeading(i)
Set C4Range = C4Workbook.Sheets(NameOfSheet(i)).Range(C4FirstColumn & C4LastRowHeading(i) + 1, C4LastColumn(i) & C4LastRow)
Set P2Range = ThisWorkbook.Sheets(NameOfSheet(i)).Range(P2ColumnStart(i) & P2LastRow + 1, P2ColumnEnd(i) & P2LastRow + NumberDataRows)
P2Range.Value(11) = C4Range.Value(11)
'copy name and profession of member next to the data
ThisWorkbook.Sheets(NameOfSheet(i)).Range("A" & P2LastRow + 1, "A" & P2LastRow + NumberDataRows).Value = _
C4Workbook.Sheets(NameOfFirstSheet).Range(CellMemberNameOnFirstSheet).Value
ThisWorkbook.Sheets(NameOfSheet(i)).Range("B" & P2LastRow + 1, "B" & P2LastRow + NumberDataRows).Value = _
C4Workbook.Sheets(NameOfFirstSheet).Range(CellProfessionOnFirstSheet).Value
'borders around member name and profession
With ThisWorkbook.Sheets(NameOfSheet(i)).Range("A" & P2LastRow + 1, "B" & P2LastRow + NumberDataRows)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
End With
'copy sheet only if there is data
End If
'loop sheets in fieldwork report
Next i
'copy name of file to column: copied correct workbooks
'(variable reference: LastRowBooksCopied tango17, FirstSheetOfCompilation tango18, ColumnNamesOfFilesCopied tango19, myFile tango3)
LastRowBooksCopied = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesOfFilesCopied).End(xlUp).Row
ThisWorkbook.Sheets(FirstSheetOfCompilation).Range(ColumnNamesOfFilesCopied & LastRowBooksCopied + 1).Value = myFile
'submission page
'(reference of variables: SubmissionSheetName tango35, LastRowSubmissionSheet tango36)
LastRowSubmissionSheet = ThisWorkbook.Sheets(SubmissionSheetName).Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Sheets(SubmissionSheetName).Range("A" & LastRowSubmissionSheet + 1).Value = VBA.Date
For j = LBound(ColumnsOnCompileSubmission) To UBound(ColumnsOnCompileSubmission)
ThisWorkbook.Sheets(SubmissionSheetName).Range(ColumnsOnCompileSubmission(j) & LastRowSubmissionSheet + 1).Value(11) = _
C4Workbook.Sheets(NameOfFirstSheet).Range(CellsOnFieldworkFirstSheet(j)).Value(11)
Next j
'end of copy book if all the conditions are met
End If
'-----------------------------------------------
'end of copy only correct books
'-----------------------------------------------
'-------------------------------------------------
'start of copy names of files for incorrect books
'-------------------------------------------------
'active sheet is not the first sheet
'first sheet is present, first sheet is not active, year is correct, version is correct, member info is correct
If CounterFirstSheetPresent = 1 And CounterFirstSheetActive = 0 And CounterYear = 1 And CounterVersion = 1 And CounterMemberInfo = 1 Then
'(variables reference: LastRowNotCopiedCntrAltDelete tango20,ColumnNamesNotCopiedCntrAltDelete tango21)
LastRowNotCopiedCntrAltDelete = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedCntrAltDelete).End(xlUp).Row
ThisWorkbook.Sheets(FirstSheetOfCompilation).Range(ColumnNamesNotCopiedCntrAltDelete & LastRowNotCopiedCntrAltDelete + 1).Value = myFile
End If
'Member info incomplete
'first sheet is present, year is correct, version is correct, member info is incomplete
If CounterFirstSheetPresent = 1 And CounterYear = 1 And CounterVersion = 1 And CounterMemberInfo = 0 Then
'(variables reference: LastRowNotCopiedMemberInfo tango29, ColumnNamesNotCopiedMemberInfo tango30)
LastRowNotCopiedMemberInfo = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedMemberInfo).End(xlUp).Row
ThisWorkbook.Sheets(FirstSheetOfCompilation).Range(ColumnNamesNotCopiedMemberInfo & LastRowNotCopiedMemberInfo + 1).Value = myFile
End If
'Wrong version
'first sheet is present, year is correct, version is incorrect, member info is correct
If CounterFirstSheetPresent = 1 And CounterYear = 1 And CounterVersion = 0 And CounterMemberInfo = 1 Then
'(variables reference: LastRowNotCopiedVersion tango31, ColumnNamesNotCopiedVersion tango32)
LastRowNotCopiedVersion = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedVersion).End(xlUp).Row
ThisWorkbook.Sheets(FirstSheetOfCompilation).Range(ColumnNamesNotCopiedVersion & LastRowNotCopiedVersion + 1).Value = myFile
End If
'wrong version and member info incomplete
'first sheet is present, year is correct, version is incorrect, member information not complete
If CounterFirstSheetPresent = 1 And CounterYear = 1 And CounterVersion = 0 And CounterMemberInfo = 0 Then
'(variables reference: LastRowNotCopiedVersionAndMemberInfo tango33, ColumnNamesNotCopiedVersionAndMemberInfo tango34)
LastRowNotCopiedVersionAndMemberInfo = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedVersionAndMemberInfo).End(xlUp).Row
ThisWorkbook.Sheets(FirstSheetOfCompilation).Range(ColumnNamesNotCopiedVersionAndMemberInfo & LastRowNotCopiedVersionAndMemberInfo + 1).Value = myFile
End If
'foreign, or wrong financial year
'first sheet is not present, or year is not correct
If CounterFirstSheetPresent = 0 Or CounterYear = 0 Then
'(variables reference: LastRowNotCopiedForeign tango25, ColumnNamesNotCopiedForeign tango26)
LastRowNotCopiedForeign = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedForeign).End(xlUp).Row
ThisWorkbook.Sheets(FirstSheetOfCompilation).Range(ColumnNamesNotCopiedForeign & LastRowNotCopiedForeign + 1).Value = myFile
End If
'-----------------------------------------------
'end of copy names of files for incorrect books
'------------------------------------------------
'close the open workbook from folder
C4Workbook.Close SaveChanges:=False
'get next member report
myFile = Dir
Loop
'end of loop files in folder
'determine last rows on first sheet of compilation after copy workbooks
LastRowBooksCopied = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesOfFilesCopied).End(xlUp).Row
LastRowNotCopiedCntrAltDelete = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedCntrAltDelete).End(xlUp).Row
LastRowNotCopiedMemberInfo = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedMemberInfo).End(xlUp).Row
LastRowNotCopiedVersion = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedVersion).End(xlUp).Row
LastRowNotCopiedVersionAndMemberInfo = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedVersionAndMemberInfo).End(xlUp).Row
LastRowNotCopiedForeign = ThisWorkbook.Sheets(FirstSheetOfCompilation).Cells(Rows.Count, ColumnNamesNotCopiedForeign).End(xlUp).Row
Call AutoFit
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'give relevant message to user
'(variable reference: LastHeadingRowOnCompilation tango27)
If LastRowNotCopiedCntrAltDelete > LastHeadingRowOnCompilation Or LastRowNotCopiedMemberInfo > LastHeadingRowOnCompilation _
Or LastRowNotCopiedVersion > LastHeadingRowOnCompilation Or LastRowNotCopiedVersionAndMemberInfo > LastHeadingRowOnCompilation _
Or LastRowNotCopiedForeign > LastHeadingRowOnCompilation Then
MsgBox "Compilation complete, however, there were problems." & vbNewLine _
& "Please rectify the Fieldwork Reports listed under the pink headings," & vbNewLine _
& "and start at step 1 again." & vbNewLine _
& "Do not make changes to data of this Compilation Report, make changes in the Fieldwork Reports", vbOKOnly, "Problem Fieldwork Reports"
ElseIf LastRowBooksCopied > LastHeadingRowOnCompilation Then
MsgBox "Compilation complete. All the reports are in the correct format."
End If
End Sub
