Report

Creating Macro for Auto Updating Multiple Workbooks

Ask a question WorldsOkayestExcelUser 3Posts Wednesday September 27, 2017Registration date September 28, 2017 Last seen - Last answered on Sep 27, 2017 at 04:10 PM by ac3mark
Hello,

I have been assigned a daunting task to create multiple reports(5) for specific clients in one workbook. This project is large as there are 47 clients.

I already have a template built for 3 of the reports (2 are pivot tables) that has 4 work sheets assigned to each client. I run a utilization report for each client and dump the data into a worksheet. From that worksheet, I sort the data, then copy and paste values into a formatted report built to send out to our officers. Refresh the pivot tables and then I can move onto the next client.

This file is LARGE and really cannot handle the additional 94 reports I need to add so I had planned on creating a new workbook with the new reports...no problem. (I have created macros to make this entire process about 45 minutes).


Someone has now decided they want to receive all of the reports in one workbook per client. These reports are updated each month and I am really trying to prevent from having to copy and paste all 235 reports into separate workbooks. I am confident there is a work around for this, I just cannot figure out all of the details.

1. My template is worked off the previous months report that constantly changes names. For example Network Report 17-8 changes to Network Report 17-9 the following month. I copy and paste the new data over the previous month's data, update the Reporting month and print each file to pdf.

2. The new reports are to be saved in individual workbooks in individual Client folders updating the reporting month in the file name. Example: Client_Name 17-8, Client_Name 17-9 etc.


Ultimately if I can just get the data to automatically update within some sort of Client template workbook, I can live with having to save all of the files individually. Any suggestions are GREATLY appreciated!!!

Helpful
-1
plus moins
So you are assigned this. COOL, I will do your work, and you do mine!
Does this sound good?

I need to build a clustered group containing a DB, a file server to hold the objects, an application server pointing to the file server to queue it all up, and a web server pointing to the App server. You get to work on that, and I will work on recording macros and converting them!


Send me the configuration flat file in XML form, and I will upload it! Thanks!

WorldsOkayestExcelUser 3Posts Wednesday September 27, 2017Registration date September 28, 2017 Last seen - Sep 27, 2017 at 04:05 PM
Perfect! Add this to the other 579 reports I already execute each month for 3 different companies in addition to AR and AP for 5 difference companies. Reports must be completed by the 15th but you can't start them until the information is available on the 1st. Also, there is a to-do list from the guy that just walked out of his job yesterday because he couldn't handle it....but I haven't gotten that far because this was at the top of it!!
Reply
ac3mark 8034Posts Monday June 3, 2013Registration date ModeratorStatus October 23, 2017 Last seen - Sep 27, 2017 at 04:07 PM
Ah yes, have FUN!

Take a look here and see if any of this helps:
http://ccm.net/faq/53497-how-to-manipulate-data-in-excel-using-vba

I can post the complete code for compiling each "winning" line into a single sheet, if you say that it will help!
Reply
ac3mark 8034Posts Monday June 3, 2013Registration date ModeratorStatus October 23, 2017 Last seen - Sep 27, 2017 at 04:10 PM
Option Explicit

Dim ApplicationID
Dim ActionCnt
Dim StartTimeForProcess
Dim endtimeforProcess
Dim QualifiedEntryText()
Dim DisqualifiedEntryText()
Dim includeEntry
Dim qst, dqst


Sub ConfigureLogic()
Dim qstEntries
Dim dqstEntries
Dim qstCnt, dqstCnt

qstEntries = Range("QualifiedEntry").Count
qst = qstEntries - WorksheetFunction.CountIf(Range("QualifiedEntry"), "")

ReDim QualifiedEntryText(qst)
'MsgBox (qst)

dqstEntries = Range("DisQualifiedEntry").Count
dqst = dqstEntries - WorksheetFunction.CountIf(Range("DisQualifiedEntry"), "")
ReDim DisqualifiedEntryText(dqst)
'MsgBox (dqst)


For qstCnt = 1 To qst
QualifiedEntryText(qstCnt) = ThisWorkbook.Worksheets("Qualifiers").Range("J" & 8 + qstCnt).value
'MsgBox (QualifiedEntryText(qstCnt))
logging ("Configured Qualified Entry entry #" & qstCnt & " as {" & QualifiedEntryText(qstCnt) & "}")
Next

For dqstCnt = 1 To dqst
DisqualifiedEntryText(dqstCnt) = ThisWorkbook.Worksheets("Qualifiers").Range("M" & 8 + dqstCnt).value
'MsgBox (DisqualifiedEntryText(dqstCnt))
logging ("Configured DisQualified Entry entry #" & qstCnt & " as {" & DisqualifiedEntryText(dqstCnt) & "}")
Next

includeEntry = ThisWorkbook.Worksheets("Qualifiers").Range("IncludeAssociate").value
'MsgBox (includeEntry)
logging ("Entrys included in search - " & includeEntry)

End Sub

Sub StartSelection()

Dim startornot
Dim dtDuration As Long
Dim minlength
Dim WhoIsPerforming
Dim StartMessage As String

StartMessage = "You are attempting to Start the Selection Process. Continue?"

WhoIsPerforming = Environ("username")
startornot = MsgBox(StartMessage, vbYesNoCancel)

If startornot <> 6 Then
logging ("Start Cancelled by [" & UCase(WhoIsPerforming) & "] with value of " & startornot)
Exit Sub

Else
logging ("User [" & UCase(WhoIsPerforming) & "] Started Selection Process.")

'Exit Sub
End If

Application.ScreenUpdating = True
ActionCnt = 0
StartTimeForProcess = Now()

logging ("Selection Start")

ConfigureLogic
logging ("Configured Logic")

'**********************************************************************************************************************
'*****This is the call to start the sheets counter, which iterates through each worksheet in the workbook*****************
'***************************************************************************************************************************
Call CountSheets

ActionCnt = ActionCnt + 1
endtimeforProcess = Now()
logging ("Selection End")
dtDuration = DateDiff("s", CDate(StartTimeForProcess), CDate(endtimeforProcess))
minlength = dtDuration / 60

logging ("Number of Transactions [" & ActionCnt & "] in " & dtDuration & " seconds (" & minlength & " mins)")

ThisWorkbook.Worksheets(1).Select
End Sub


Private Sub CountSheets()
Dim sheetcount
Dim WS As Worksheet

sheetcount = 0


logging ("*****Starting Scrub*********")
For Each WS In ThisWorkbook.Worksheets
sheetcount = sheetcount + 1
If (WS.Name <> "Controller") Then

If (WS.Name <> "Qualifiers") Then

If WS.Name <> "EntryDropped" Then
If WS.Name <> "Logging" Then

If WS.Name <> "Selected" Then
'need to log the date and time into sheet named "Logging"
ActionCnt = ActionCnt + 1
logging ("Calling sheet: " & WS.Name)
scrubsheet (sheetcount)
Else
ActionCnt = ActionCnt + 1
logging ("Skipped over sheet: " & WS.Name)
End If

Else
ActionCnt = ActionCnt + 1
logging ("Skipped over sheet: " & WS.Name)
End If

Else
ActionCnt = ActionCnt + 1
logging ("Skipped over sheet: " & WS.Name)
End If

Else
ActionCnt = ActionCnt + 1
logging ("Skipped over sheet: " & WS.Name)
End If

Else
ActionCnt = ActionCnt + 1
logging ("Skipped over " & WS.Name)
End If

Next WS
'MsgBox ("ending")
ActionCnt = ActionCnt + 1

logging ("****Scrub DONE!")
Application.ScreenUpdating = True


End Sub



Private Function logging(whatvalue)
Dim cellcount
Dim thecelltoinput
Dim Osheet

Osheet = ThisWorkbook.ActiveSheet.Name
ThisWorkbook.Worksheets("Logging").Select
thecelltoinput = 0
whatvalue = Now & "--" & ActionCnt & "--" & whatvalue
cellcount = Cells(ThisWorkbook.Worksheets("Logging").Rows.Count, 1).End(xlUp).Row
'MsgBox (cellcount & "was the count")
thecelltoinput = cellcount + 1
ThisWorkbook.Worksheets("Logging").Range("a" & thecelltoinput).value = whatvalue
ThisWorkbook.Worksheets(Osheet).Select
End Function


Sub SortTheSheet()

Range("A6:AZ9999").Sort key1:=Range("AW5"), _
order1:=xlDescending, Header:=xlNo

Range("A6:AZ9999").Sort key1:=Range("AT5"), _
order1:=xlAscending, Header:=xlNo

End Sub





Private Sub scrubsheet(WS)

Dim z
Dim placevalue
Dim RefRange, firstrange, SelectionRange, thirdrange, fourthrange, Entryrange, WeightedSelectionRange
Dim SelectionExists
Dim NumberOfSeats, NumOfSelectedSeatsCount
Dim Loggingentry, loggingSTMNT
Dim Nret, retNum
Dim worksheetName
Dim TypeOfPlace 'Number of Seats Per place
Dim PlaceType 'small medium or large place
Dim SeatsPerPlace()
Dim Seat0, Seat1, Seat2, Seat3, Seat4, Seat5
Dim SeatLevel
Dim LevelName
Dim SelectionAction
Dim whatrow
Dim WeightedSelection
Dim IsAssociate
Dim gradecount
Dim loggingCnt
Dim lookfordisqualified
Dim lookforqualified


IsAssociate = 0

ActionCnt = ActionCnt + 1

ThisWorkbook.Worksheets(WS).Select
worksheetName = ThisWorkbook.Worksheets(WS).Name


NumberOfSeats = ThisWorkbook.Worksheets(WS).Range("A4").value
SelectionExists = Range("M2").value

If SelectionExists = "NA" Then
'**********DEBUG****************************************************
'MsgBox ("No Selection on sheet " & Worksheets(WS).Name)
'*******************************************************************
logging ("No Selection on sheet: " & worksheetName)
SelectionExists = 0
Else
logging ("Located Winning Selection #: " & SelectionExists & " for " & worksheetName)
End If

If NumberOfSeats = 0 Then
Loggingentry = "***Warning - No Seats configured for " & worksheetName & ". Please verify Planning numbers are correct.***"
logging (Loggingentry)

'Loggingentry = "VV Premature Exit from run on [" & worksheetName & "]. VV"
'logging (Loggingentry)
'Exit Sub
End If


'***********************************************************************************************
'******************This section sets up the variable grade seats that are **********************
'****************** available to each Place. The variables are stored in *********************
'****************** the array of SeatsPerPlace(N) **********************************************
'****************** SeatPerGrade(N) has the MAX number of each Seat Level per Place ****************
'******************As each seat is identified as selected, we subtract one from the ************
'****************** Appropriate place in th earray. We continue to select until the ***********
'****************** app. place has 0, then those applicants are put on a waiting list**************
'***********************************************************************************************


TypeOfPlace = 0
'need to load array SeatsPerPlace by identifying what kind of Place it is
retNum = InStr(1, worksheetName, "Small", vbTextCompare)
If retNum <> 0 Then
TypeOfPlace = 5 'Small
PlaceType = "Small Place"
End If


retNum = InStr(1, worksheetName, "Medium", vbTextCompare)
If retNum <> 0 Then
TypeOfPlace = 2 'Medium Place
PlaceType = "Medium Place"
End If

retNum = InStr(1, worksheetName, "Large", vbTextCompare)
If retNum <> 0 Then
TypeOfPlace = 3 'Large Place
PlaceType = "Large Place"
End If

logging ("Found " & worksheetName & " is a " & PlaceType & ", and has [" & TypeOfPlace + 1 & "] grades in it.")

ReDim SeatsPerPlace(TypeOfPlace + 1)

For gradecount = 0 To TypeOfPlace
SeatsPerPlace(gradecount) = ThisWorkbook.Worksheets(WS).Cells(2, 7 + gradecount).value
Next

logging ("Loaded the SeatsPerPlace(" & TypeOfPlace & ") Array as follows below:")

For loggingCnt = 0 To TypeOfPlace
loggingSTMNT = "Place: " & worksheetName & "--SeatsPerPlace(" & loggingCnt & "): " & SeatsPerPlace(loggingCnt)
logging (loggingSTMNT)
Next



z = Cells(ThisWorkbook.Worksheets(WS).Rows.Count, 1).End(xlUp).Row

If z > SelectionExists Then
ActionCnt = ActionCnt + 1
logging ("Disregarding Selection results, as the number of Seats is greater than the number of Applicants/Selection Winners!")
End If

If z > 5 Then
'WaitingList (WS)
NumOfSelectedSeatsCount = 0

'**************************Selected List Formula below***************
'************need to see if we want to include Associates from the Qualifiers sheet
If LCase(includeEntry) = "no" Then
GoTo skiptheAssociates
End If



For placevalue = 6 To z
RefRange = "C" & placevalue
firstrange = "AR" & placevalue
SelectionRange = "AW" & placevalue
thirdrange = "AT" & placevalue
fourthrange = "AU" & placevalue
Entryrange = "AS" & placevalue
WeightedSelectionRange = "AX" & placevalue

For lookfordisqualified = 1 To dqst 'loops through array to find all matching text from DisqualifiedEntry on Qualifiers sheet
If LCase(Range(Entryrange).value) Like DisqualifiedEntryText(lookfordisqualified) Then
ActionCnt = ActionCnt + 1
logging ("[" & worksheetName & "] [refID(" & Range(RefRange).value & ")] found an associate, was dropped: " & Range(Entryrange).value)
Nret = selectRow(placevalue, "EntryDropped")
logging ("Above Applicant was placed in Entry Dropped sheet for audit")
GoTo skiptherecord
End If
Next

For lookforqualified = 1 To qst 'loops through array to find all matching text from QualifedAssociate on Qualifiers sheet
If LCase(Range(Entryrange).value) Like QualifiedEntryText(lookforqualified) Then
ActionCnt = ActionCnt + 1
logging ("**** [" & worksheetName & "] found an associate: " & Range("AS" & placevalue).value)
'WeightedSelection = Range(SelectionRange).value + 10000
WeightedSelection = Range(SelectionRange).value 'no weight added to Selection number, just identify as Associate in next column over.
logging ("->Placed a marker for RefID[" & Range(RefRange).value & "]")
Range(WeightedSelectionRange).value = Range(SelectionRange).value
'Range(SelectionRange).value = WeightedSelection
End If
Next
skiptherecord:
Next
skiptheAssociates:


ActionCnt = ActionCnt + 1
logging ("End of Entry scrub for - " & worksheetName & ".")

ActionCnt = ActionCnt + 1
SortTheSheet
logging ("Sorted worksheet [" & worksheetName & "] for Selection Selection...")

For placevalue = 6 To z

IsAssociate = 0 'default is 0=not an associate/1=is an associate for seat counts
RefRange = "C" & placevalue
firstrange = "AR" & placevalue
SelectionRange = "AW" & placevalue
thirdrange = "AT" & placevalue
fourthrange = "AU" & placevalue
Entryrange = "AS" & placevalue
WeightedSelectionRange = "AX" & placevalue

'****Need to find all of the selected 1st Place choices, and then see how many seats are left over.
If ((Range(firstrange).value = "Approved") _
And _
(NumOfSelectedSeatsCount <= NumberOfSeats) _
And _
(Range(SelectionRange).value >= SelectionExists) _
And _
(Range(SelectionRange).value <> "") _
And _
(Range(thirdrange).value = 1) _
And _
(LCase(Range(fourthrange).value) = LCase(worksheetName))) Then

If Range(WeightedSelectionRange).value <> "" Then
logging ("Trapped Entry [refID - " & Range(RefRange).value & "]...")
IsAssociate = 1
End If

GoSub CheckForSeats
End If

Next
'end of 1st preference scrub

ActionCnt = ActionCnt + 1
logging ("End of Primary scrub for - " & worksheetName & ".")

For placevalue = 6 To z
RefRange = "C" & placevalue
firstrange = "AR" & placevalue
SelectionRange = "AW" & placevalue
thirdrange = "AT" & placevalue
fourthrange = "AU" & placevalue
Entryrange = "AS" & placevalue
WeightedSelectionRange = "AX" & placevalue

'************************Check to see if Place is selected and there is available seats to select
If ((Range(firstrange).value = "Approved") _
And _
(NumOfSelectedSeatsCount < NumberOfSeats) _
And _
(Range(SelectionRange).value < SelectionExists) _
And _
(Range(SelectionRange).value <> "") _
And _
(Range(thirdrange).value = 1) _
And _
(LCase(Range(fourthrange).value) = LCase(worksheetName))) Then
GoSub CheckForSeats

logging ("Above Applicant [" & ApplicationID & "] did not win Selection...")
logging ("...sent to check for available seat. Result [" & SelectionAction & "] (0=selected, 1 = WaitingList)")

'NumOfSelectedSeatsCount = NumOfSelectedSeatsCount + 1
'Else
'**************************Waiting List Formula below***************
' If ((Range(firstrange).value = "Approved") _
' And _
' (Range(SelectionRange).value < SelectionExists) _
' And _
' (Range(SelectionRange).value <> "") _
' And _
' (Range(thirdrange).value = 1) _
' And _
' (LCase(Range(fourthrange).value) = LCase(worksheetName))) Then
' GoSub CheckForSeats
' 'Nret = selectRow(placevalue, "WaitingList")
' End If

End If
Next

Else
ActionCnt = ActionCnt + 1

Loggingentry = "No Valid Entries for Sheet: " & worksheetName
logging (Loggingentry)
End If
ActionCnt = ActionCnt + 1
logging ("~~Finish of Scrub, now closing Sheet: " & worksheetName)
Exit Sub

PlaceOnSheet:

If SelectionAction = 0 Then 'Selected
Nret = selectRow(placevalue, "Selected")
NumOfSelectedSeatsCount = NumOfSelectedSeatsCount + 1
Loggingentry = "Seat selection #" & NumOfSelectedSeatsCount & ", with " & SeatsPerPlace(LevelName) & " seats left "

If LevelName = "0" Then LevelName = "Bowl"

Loggingentry = Loggingentry & " in the (" & LevelName & ") grade level"
logging (Loggingentry)
End If

If SelectionAction = 1 Then 'Waitinglist
logging ("Waiting List Placement...")
Nret = selectRow(placevalue, "WaitingList")
End If

If SelectionAction = 2 Then 'Associate
Nret = selectRow(placevalue, "SELECTED")
NumOfSelectedSeatsCount = NumOfSelectedSeatsCount + 1
logging ("Placed Entry in Selected listing.")
End If

Return

CheckForSeats:
ActionCnt = ActionCnt + 1
SeatLevel = 0
LevelName = 0
SeatLevel = ThisWorkbook.Worksheets(WS).Range("AN" & placevalue).value
'MsgBox ("Applicant is in grade: " & SeatLevel)
GoSub SetupGrade
'MsgBox ("SeatLevel was converted to name of: " & LevelName)
'MsgBox ("there are " & SeatsPerPlace(LevelName) & " seats in " & SeatLevel & " for this Place.")

If IsAssociate = 1 Then 'this Applicant is a Associate and wins a seat regardless
If SeatsPerPlace(LevelName) <= 0 Then
SelectionAction = 1
Else
SelectionAction = 2
End If
SeatsPerPlace(LevelName) = SeatsPerPlace(LevelName) - 1
GoSub PlaceOnSheet
Return
End If


If SeatsPerPlace(LevelName) > 0 Then
SeatsPerPlace(LevelName) = SeatsPerPlace(LevelName) - 1
SelectionAction = 0
GoSub PlaceOnSheet
Return
End If

If SeatsPerPlace(LevelName) <= 0 Then
SelectionAction = 1
GoSub PlaceOnSheet
Return
End If

Return

SetupGrade:
If TypeOfPlace = 5 Then 'Small
If LCase(SeatLevel) = "Bowl" Then
LevelName = 0
End If
If LCase(SeatLevel) = 1 Then
LevelName = 1
End If
If LCase(SeatLevel) = 2 Then
LevelName = 2
End If
If LCase(SeatLevel) = 3 Then
LevelName = 3
End If
If LCase(SeatLevel) = 4 Then
LevelName = 4
End If
If LCase(SeatLevel) = 5 Then
LevelName = 5
End If
End If
If TypeOfPlace = 2 Then 'Medium
If LCase(SeatLevel) = 1 Then
LevelName = 0
End If
If LCase(SeatLevel) = 2 Then
LevelName = 1
End If
If LCase(SeatLevel) = 3 Then
LevelName = 2
End If
End If
If TypeOfPlace = 3 Then 'Large
If LCase(SeatLevel) = "Bowl" Then
LevelName = 0
End If
If LCase(SeatLevel) = 1 Then
LevelName = 1
End If
If LCase(SeatLevel) = 2 Then
LevelName = 2
End If
If LCase(SeatLevel) = 3 Then
LevelName = 3
End If
End If

Return
End Sub




Private Function selectRow(whatrow, whatsheet)
Dim X
Dim thecell
Dim LoggingRowID
Dim AppID
Dim AppsLotto
Dim WinningLotto
Dim Nret
Dim WSOriginal 'need to keep track of what sheet we are working on as the subroutine cascades
Dim LogString


WSOriginal = ThisWorkbook.ActiveSheet.Name 'we have a value for the active sheet to return too
'*********************************************************
'**Sets up logging string Construct for Auditing *************
'****************************************************************
LoggingRowID = Range("A" & whatrow).value
AppID = Range("B" & whatrow).value
AppsLotto = Range("AW" & whatrow).value
WinningLotto = Range("M2").value
If LCase(whatsheet) = "selected" Then
LogString = "-->>"
End If

ApplicationID = ""

ApplicationID = AppID



'***************************************************************
'****END OF LOGGING CONSTRUCT*******************************
'****************************************************

ActiveSheet.Range("A" & whatrow).EntireRow.Select 'Find the Row we are scrubbng and highlight it for copying and pasting
Selection.Copy
logging (LogString & whatsheet & " Entry - Copying Row [" & LoggingRowID & "] ...")
logging ("... APPID={" & AppID & "} " & _
"from [" & WSOriginal & "]. Apps Lotto: " & AppsLotto)

ThisWorkbook.Worksheets(whatsheet).Select ' now that we have the original sheet, we can switch to the appropriate(dynamically selected) list sheet.

X = Cells(ThisWorkbook.Worksheets(whatsheet).Rows.Count, 1).End(xlUp).Row
thecell = X + 1

Nret = copyRow(thecell, whatsheet)
ThisWorkbook.Worksheets(WSOriginal).Select 'Return to the original sheet for the next record
'Range("A1").Activate
'Application.CutCopyMode = False

End Function


Private Function copyRow(whatrow, whatsheet)
ActiveSheet.Paste Destination:=Worksheets(whatsheet).Range("A" & whatrow)
Application.CutCopyMode = False
End Function




Reply
Leave a comment

Member requests are more likely to be responded to.

Members can monitor the statuses of their requests from their account pages.

A CCM membership gives you access to additional options.

Not a member yet?

Sign up now. It takes less than a minute and is completely free!