Public strNewReviewFINAL As String
Sub CommandButton3_Click()
'update daily NRO data file to Master
CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path
Dim UpdateFileName As Variant
Dim Sourcewb As Workbook, ESMwb As Workbook
Dim WS As Worksheet
Dim MainWS As Worksheet
Dim pos As Integer
Dim strNewReviewExt, strNewReview As String
Dim CopyToRow As Integer
With Application
.EnableEvents = False
.ScreenUpdating = False
' Use this code to suppress "sheet deletion" warning
.DisplayAlerts = False
End With
'MSG BOX TO ASK IF USER INTENDS TO UPDATE FILE
If MsgBox("Do you wish to update the NRO Spreadsheet - News?", vbYesNo, "UPDATE") = vbNo Then Exit Sub
Set Sourcewb = ThisWorkbook
'VARIABLES TO TRIM NAME OF SOURCE WORKBOOK DOWN TO NEW OR REVIEW
'GET ONLY FILENAME (LEFT OF .)
strNewReviewExt = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
'FIND POSITION OF THE HYPHEN
pos = InStrRev(strNewReviewExt, "-")
'GRAB LETTERS TO THE RIGHT OF THE HYPHEN
strNewReview = Trim(Right(strNewReviewExt, Len(strNewReviewExt) - pos))
'REMOVE THE S FROM THE END
strNewReviewFINAL = Replace(strNewReview, "s", "")
'VARIABLE TO NAME DESIRED WORKSHEET IN SOURCEWB
Set MainWS = Sourcewb.Worksheets(strNewReviewFINAL)
On Error Resume Next
,CLEAR ALL FILTERS AND FIND LAST USED ROW
If MainWS.Visible Then MainWS.ShowAllData
CopyToRow = MainWS.Range("A" & Rows.Count).End(xlUp).Row + 1
'Name the folder to use
ChDir "\\qldhealth\.Herston-CL1_DATA10.Herston.IN-BNE.BNS.HEALTH\RBWHNRO\ESM Daily Reports"
'which file is it?
UpdateFileName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If UpdateFileName = False Then Aborted = True: Exit Sub
'ASSIGN VARIABLE NAME FOR OTHER WORKBOOK
Set ESMwb = Workbooks.Open(UpdateFileName)
With ESMwb
'USE SELECT SHEET TO UNGROUP
.Sheets(1).Select
'ALL SHEETS UNFILTER AND UNHIDE RCs
For Each WS In ESMwb.Worksheets
On Error Resume Next
If WS.Visible Then WS.ShowAllData
On Error GoTo 0
WS.UsedRange.EntireColumn.Hidden = False
WS.UsedRange.EntireRow.Hidden = False
Next WS
End With
'MERGE ALL SHEETS ONTO MASTER SHEET, REORDER COLUMNS, FILTER FOR WHAT WE WANT
Application.Run "CopyFromWorksheets"
'COPY ALL BUT LAST COLUMN TO SOURCEWB
With ESMwb.ActiveSheet.AutoFilter.Range
.Offset(1, 0).Resize(.Rows.Count - 1, 11).Copy Destination:=MainWS.Range("A" & CopyToRow)
End With
'CLOSE OTHER WORKBOOK WITHOUT SAVING
ESMwb.Close (False)
'Inform the user the macro is completed
MsgBox "The file ''" & UpdateFileName & "'' has successfully updated the NRO Spreadsheet - " & strNewReview & ".", _
64, "Update Complete."
End Sub
Sub CopyFromWorksheets()
'/// This code assumes that ALL worksheets have the same field structure; same column headings, and the same column order.
'/// The code copies all rows into one new worksheet called Master.
'/// think this was written by smozgur (VBA Express???)
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(1048576, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(1048576, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
Rows("2:2").Select
ActiveWindow.FreezePanes = True
'Screen updating should be activated
With Application
.Run "ReorderColumns"
.Run "Remove_unwanted_columns"
.Run "FilterRows"
.ScreenUpdating = True
End With
'///1048576 rows for excel 2007 onwards
End Sub
Sub ReorderColumns()
'Code contribution by AlphaFrog (Excel MVP) in
'http://www.mrexcel.com/forum/excel-questions/606890-reorder-columns-using-macro.html
Dim arrColOrder As Variant, ndx As Integer
Dim Found As Range, counter As Integer
With ActiveWorkbook.Sheets("Master")
'Place the column headers in the end result order you want.
arrColOrder = Array("LOCAL_BUS_UNIT", "APPT_DATE", "APPT_TIME", "MRN", "Name", _
"DOB", "Appointment Type", "ESM_Resource", "Referral_Length", "Referral_Expiry_Date", _
"Referred To Named Referral (Yes/No)", "STATUS_DESCRIPTION")
counter = 1
Application.ScreenUpdating = False
For ndx = LBound(arrColOrder) To UBound(arrColOrder)
Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Found Is Nothing Then
If Found.Column <> counter Then
Found.EntireColumn.Cut
Columns(counter).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next ndx
End With
Application.ScreenUpdating = True
End Sub
Sub Remove_unwanted_columns()
With ActiveWorkbook
.Sheets("Master").Range("M:Z").EntireColumn.Delete
End With
End Sub
Sub FilterRows()
Dim strDesc, strAppt, strRefLength, strNR As String
Dim rngHdr As Range
Dim af1, af2, af3, af4 As Integer
With ActiveWorkbook.Sheets("Master")
Set rngHdr = .Range("A1:L1")
strDesc = "STATUS_DESCRIPTION"
strAppt = "Appointment Type"
strNR = "Referred To Named Referral (Yes/No)"
strRefLength = "Referral_Length"
af1 = Application.WorksheetFunction.Match(strDesc, rngHdr, 0)
af2 = Application.WorksheetFunction.Match(strAppt, rngHdr, 0)
af3 = Application.WorksheetFunction.Match(strNR, rngHdr, 0)
af4 = Application.WorksheetFunction.Match(strRefLength, rngHdr, 0)
End With
With ActiveWorkbook.Sheets("Master").Range("A1:L1")
.AutoFilter Field:=af1, Criteria1:="<>*Expired*"
.AutoFilter Field:=af2, Criteria1:="*" & strNewReviewFINAL & "*"
.AutoFilter Field:=af3, Criteria1:="<>*Yes*"
.AutoFilter Field:=af4, Criteria1:="<>*3 Months*"
End With
End Sub
