毎月、私たちのベンダーからデータをダウンロードしますが、これは小規模ですが、ルックアップ式を使用するのが容易ではない形式になっています。次に、セル参照の混乱でそれを読み、正しい場所を探していることを願っています. データを読み取り、下の画像のように構造化する最良の方法は何でしょうか。列 A:G を 1 か月読み、翌月は A:H になりますが、最大 12 か月しかありません。次に、I2:K10 に示されているように、レポートで機能するように構成します。
「場所」には、ベンダーからのダウンロードにデータがない場合があります。そのため、場所が変更されています。また、これらの小さなデータ範囲を約 30 個ダウンロードして、より大きなレポートにまとめる必要があります。また、データは独自のシートに貼り付けられ、プルされたデータは別のシートに貼り付けられます。セルの数式だけでなく、VBA の提案も受け付けています。
さまざまな色があり、何を読もうとしているか、どこに書く必要があるかを示しています。
ありがとう、
-Scheballs
これは、パート 2のコードのサブルーチンを含むパート 3です。第 1 部で導入。
Function CheckBound(ByRef CellValue As Variant, _
ByVal RowFile As Long, ByVal ColFile As Long, _
ByRef Msg As String)
' Return True if CellValue(RowFile, ColFile) exists
If RowFile > UBound(CellValue, 1) Then
' Row not present in file
CheckBound = False
Msg = "No such row within file"
Exit Function
End If
If ColFile > UBound(CellValue, 2) Then
' Column not present in file
CheckBound = False
Msg = "No such column within file"
Exit Function
End If
CheckBound = True
End Function
Sub CheckCellValueMultiple(ByRef FileNameCrnt As String, _
ByRef CellValue As Variant, _
ByRef CellError As Boolean, _
ByVal RowFile As Long, ByVal ColFile As Long, _
ByRef ValueReq() As Variant, _
ByRef InxValue As Long, _
ByRef RowErrorCrnt As Long)
' Check that a specified cell of a CSV file has one of a number of permitted
' values.
' Set CellError is True if the cell does not have any of the permitted
' required value.
' CellError is unchanged if the cell does have the required value. This means
' that several calls can be made to perform different checks and any failure
' will result in CellValue ending with a value of True.
' FileNameCrnt The name of the current file. Used in error message if any.
' CellValue The array of cell contents from the current file.
' CellError Set to True if an error is found.
' RowFile The row to be checked
' ColFile The column to be checked
' ValueReq An array containing all permitted values for the cell.
' InxValue If the cell value is matched against one of the permitted
' values, the index into ValueReq of that permitted value.
' RowErrorCrnt The last used row of the error worksheet. Any error message
' will be written to the next row.
Dim CellValueCrnt As Variant
Dim ErrMsg As String
If Not CheckBound(CellValue, RowFile, ColFile, ErrMsg) Then
Call RecordError(FileNameCrnt, RowFile, ColFile, ErrMsg, RowErrorCrnt)
CellError = True
Exit Sub
End If
CellValueCrnt = CellValue(RowFile, ColFile)
For InxValue = LBound(ValueReq) To UBound(ValueReq)
If CellValueCrnt = ValueReq(InxValue) Then
' Cell value matched against a permitted value
Exit Sub
End If
Next
Call RecordError(FileNameCrnt, RowFile, ColFile, _
"""" & CellValue(RowFile, ColFile) & _
""" not matched against any of the permitted values", _
RowErrorCrnt)
CellError = True
End Sub
Sub CheckCellValueSingle(ByRef FileNameCrnt As String, _
ByRef CellValue As Variant, _
ByRef CellError As Boolean, _
ByVal RowFile As Long, ByVal ColFile As Long, _
ByVal ValueReq As String, ByRef RowErrorCrnt As Long)
' Check that a specified cell of a CSV file has a required value.
' Set CellError is True if the cell does not have the required value.
' CellError is unchanged if the cell does have the required value. This means
' that several calls can be made to perform different checks and any failure
' will result in CellValue ending with a value of True.
' FileNameCrnt The name of the current file. Used in error message if any.
' CellValue The array of cell contents from the current file.
' CellError Set to True if an error is found.
' RowFile The row to be checked
' ColFile The column to be checked
' ValueReq The required value for the cell
' RowErrorCrnt The last used row of the error worksheet. Any error message
' will be written to the next row.
Dim ErrMsg As String
If Not CheckBound(CellValue, RowFile, ColFile, ErrMsg) Then
Call RecordError(FileNameCrnt, RowFile, ColFile, ErrMsg, RowErrorCrnt)
CellError = True
Exit Sub
End If
If CellValue(RowFile, ColFile) = ValueReq Then
' Required value found
Exit Sub
End If
Call RecordError(FileNameCrnt, RowFile, ColFile, """" & ValueReq & _
""" expected but """ & CellValue(RowFile, ColFile) _
& """ found", RowErrorCrnt)
CellError = True
End Sub
Sub CheckDateRangeLocn(ByVal FileNameCrnt As String, _
ByRef CellValue As Variant, _
ByRef CellError As Boolean, ByVal RowFile As Long, _
ByVal ColFile As Long, ByRef DateStart As Date, _
ByRef DateEnd As Date, ByRef RowErrorCrnt As Long)
' Check a specified cell of a CSV file has the format:
' Date "-" Date "Location Comparison Based on" N "Locations"
' Set CellError = True if the cell does not have this value.
' The values of DateStartCrnt and DateEndCrnt are not defined
' if CellError is set to True,
' Note: the value of N is not returned
' FileNameCrnt The name of the current file. Used in error message if any.
' CellValue The array of cell contents from the current file.
' CellError Set to True if an error is found.
' RowFile The row to be checked
' ColFile The column to be checked
' DateStartCrnt The value of the first date. Only guaranteed if CellError
' not set to True
' DateEndCrnt The value of the last date. Only guaranteed if CellError
' not set to True
' RowErrorCrnt The last used row of the error worksheet. Any error message
' will be written to the next row.
Dim ErrMsg As String
Dim Pos As Long
Dim Stg As String
If Not CheckBound(CellValue, RowFile, ColFile, ErrMsg) Then
Call RecordError(FileNameCrnt, RowFile, ColFile, ErrMsg, RowErrorCrnt)
CellError = True
Exit Sub
End If
Stg = CellValue(3, 1)
Pos = InStr(1, Stg, "-")
If Pos = 0 Then
' No hypen in string.
CellError = True
Exit Sub
End If
If Not IsDate(Mid(Stg, 1, Pos - 1)) Then
' Value before hyphen is not a date
CellError = True
Exit Sub
End If
DateStart = DateValue(Mid(Stg, 1, Pos - 1))
Stg = Mid(Stg, Pos + 1)
Pos = InStr(1, Stg, "Location Comparison Based on")
If Pos = 0 Then
' Important sub-string missing
CellError = True
Exit Sub
End If
If Not IsDate(Mid(Stg, 1, Pos - 1)) Then
' Value after hyphen is not a date
CellError = True
Exit Sub
End If
DateEnd = DateValue(Mid(Stg, 1, Pos - 1))
Stg = Mid(Stg, Pos + Len("Location Comparison Based on"))
If Not Right(Stg, Len("Locations")) = "Locations" Then
' Important sub-string missing
CellError = True
Exit Sub
End If
Stg = Mid(Stg, 1, Len(Stg) - Len("Locations"))
If Not IsNumeric(Stg) Then
' N is not numeric
CellError = True
Exit Sub
End If
' CellError unchanged. DateStart and DateEnd set
End Sub
Sub CheckDateSequence(ByVal FileNameCrnt As String, _
ByRef CellValue As Variant, ByRef RangeError As Boolean, _
ByVal RowFileStart As Long, ByVal ColFileStart As Long, _
ByVal DateStart As Date, ByVal DateEnd As Date, _
ByVal Direction As String, ByVal Interval As String, _
ByRef RowErrorCrnt As Long)
' Check a sequence of cells to hold a sequence of dates.
' FileNameCrnt The name of the current file. Used in error message if any.
' CellValue An array of cell contents from the current file.
' RangeError Set to True if an error is found.
' RowFileStart \ Identify the first cell of the sequence
' ColFileStart /
' DateStart The value of the first date in the sequence.
' DateEnd The value of the last date in the sequence.
' Direction Permitted values are "a" for across and "d" for down.
' Interval Permitted values are as for the Interval parameter of the
' function DateAdd. Each cell in the sequence must be one
' date interval more than the previous cell until DateEnd is
' reached.
' RowErrorCrnt The last used row of the error worksheet. Any error message
' will be written to the next row.
Dim ColFileCrnt As Long
Dim DateCrnt As Date
Dim DateTemp As Date
Dim ErrMsg As String
Dim RowFileCrnt As Long
DateCrnt = DateStart
RowFileCrnt = RowFileStart
ColFileCrnt = ColFileStart
Do While True
If Not CheckBound(CellValue, RowFileCrnt, ColFileCrnt, ErrMsg) Then
Call RecordError(FileNameCrnt, RowFileCrnt, _
ColFileCrnt, ErrMsg, RowErrorCrnt)
RangeError = True
Exit Sub
End If
If Not IsDate(CellValue(RowFileCrnt, ColFileCrnt)) Then
' Value is not a date nor is it a string that can be converted to a date
Call RecordError(FileNameCrnt, RowFileCrnt, ColFileCrnt, _
"Value should be """ & Format(DateCrnt, FmtDate) & _
""" but found """ & CellValue(RowFileCrnt, ColFileCrnt) _
& """", RowErrorCrnt)
RangeError = True
Exit Sub
End If
DateTemp = DateValue(CellValue(RowFileCrnt, ColFileCrnt))
If DateTemp = DateCrnt Then
' Cell has expected value
Else
' Cell does not have the expected value
' Excel corrupts "mmm-yy" to Day=yy, Month=mmm, Year=Current year
DateTemp = DateSerial(Day(DateTemp), Month(DateTemp), 1)
If DateTemp = DateCrnt Then
' Decorrupted value is the expected value
' Correct worksheet
CellValue(RowFileCrnt, ColFileCrnt) = DateTemp
Else
Call RecordError(FileNameCrnt, RowFileCrnt, ColFileCrnt, _
"Value should be """ & Format(DateCrnt, FmtDate) & _
""" but found """ & CellValue(RowFileCrnt, ColFileCrnt) _
& """", RowErrorCrnt)
RangeError = True
Exit Sub
End If
End If
If DateCrnt = DateEnd Then
' Successful check. Leave RangeError unchanged.
Exit Sub
End If
DateCrnt = DateAdd(Interval, 1, DateCrnt)
If Direction = "a" Then
ColFileCrnt = ColFileCrnt + 1
ElseIf Direction = "d" Then
RowFileCrnt = RowFileCrnt + 1
Else
Debug.Assert False ' Invalid value. Only "a" or "d" allowed
End If
Loop
End Sub
Sub ExtractSubArray(ByRef ArraySrc() As Variant, ByRef ArrayDest As Variant, _
ByVal RowSrcTop As Long, ByVal ColSrcLeft As Long, _
ByVal RowSrcBot As Long, ByVal ColSrcRight As Long)
' ArraySrc An array loaded from a worksheet
' ArrayDest A variant which will be set to an array to which selected
' entries from ArraySrc are to be copied. If either
' RowTop = RowBot or Colleft = ColRight it will be a 1D array.
' Otherwise it will be a 2D array with rows as the first
' dimension.
' RowSrcTop \ Specify the rectangle to be extracted from ArraySrc.
' ColSrcLeft |
' RowSrcBot | It is the callers responsibility to ensure the
' ColSrcRight / these values are valid indices for ArraySrc.
Dim ArrayDestLocal() As Variant
Dim ColDestCrnt As Long
Dim ColSrcCrnt As Long
Dim NumColsDest As Long
Dim NumRowsDest As Long
Dim RowDestCrnt As Long
Dim RowSrcCrnt As Long
NumColsDest = ColSrcRight - ColSrcLeft + 1
NumRowsDest = RowSrcBot - RowSrcTop + 1
If NumColsDest = 1 Then
' The selected rectangle is a column
ReDim ArrayDestLocal(1 To NumRowsDest)
RowDestCrnt = 1
For RowSrcCrnt = RowSrcTop To RowSrcBot
ArrayDestLocal(RowDestCrnt) = ArraySrc(RowSrcCrnt, ColSrcLeft)
RowDestCrnt = RowDestCrnt + 1
Next
ArrayDest = ArrayDestLocal
ElseIf NumRowsDest = 1 Then
' The selected rectangle is a row
ReDim ArrayDestLocal(1 To NumColsDest)
ColDestCrnt = 1
For ColSrcCrnt = ColSrcLeft To ColSrcRight
ArrayDestLocal(ColDestCrnt) = ArraySrc(RowSrcTop, ColSrcCrnt)
ColDestCrnt = ColDestCrnt + 1
Next
ArrayDest = ArrayDestLocal
Else
' The selected rectangle is a rectangle
ReDim ArrayDestLocal(1 To NumRowsDest, 1 To NumColsDest)
RowDestCrnt = 1
For RowSrcCrnt = RowSrcTop To RowSrcBot
ColDestCrnt = 1
For ColSrcCrnt = ColSrcLeft To ColSrcRight
ArrayDestLocal(RowDestCrnt, ColDestCrnt) = _
ArraySrc(RowSrcCrnt, ColSrcCrnt)
ColDestCrnt = ColDestCrnt + 1
Next
RowDestCrnt = RowDestCrnt + 1
Next
ArrayDest = ArrayDestLocal
End If
End Sub
Sub RecordError(ByRef FileName As String, ByRef RowFile As Long, _
ByRef ColFile As Long, ByRef Msg As String, _
ByRef RowError As Long)
' Outputs an error to the error worksheet
Debug.Assert Not IsNumeric(FileName)
With Worksheets(WkShtNameError)
RowError = RowError + 1
With .Cells(RowError, ColErrorTime)
.Value = Now()
.NumberFormat = FmtDateTime
End With
.Cells(RowError, ColErrorFile).Value = FileName
If RowFile <> 0 Then .Cells(RowError, ColErrorRow).Value = RowFile
If ColFile <> 0 Then .Cells(RowError, ColErrorCol).Value = ColFile
With .Cells(RowError, ColErrorMsg)
.Value = Msg
.WrapText = True
End With
End With
End Sub
これは、ソリューションを紹介し、メインルーチンを含む回答のパート 2 です。 パート 3には、サブルーチンが含まれています。 パート 1では、ソリューションで使用する手法を紹介します。
私の解決策では、マクロのワークブックに 2 つのワークシートが含まれている必要があります。1 つはエラー用で、もう 1 つは統合データ用です。これらのワークブックの名前は定数として定義されているため、必要に応じて変更できます。
ダウンロードしたファイルの形式と一致すると思われる CSV ファイルをいくつか作成しました。典型的な例は次のとおりです。
1 Caution: Rates Have Not Been Adjusted For Patient Mix
2 St Anthony's Hospital
3 Jan 2013 - April 2013 Location Comparison Based on 6 Locations
4 CMS Qualified HCAHPS Data from All Service Lines
5 Communications about Medications Composite Results
6 Location,Jan 2013,Feb 2013,Mar 2013,Apr 2013,Composite Rate,Percentile
7 2E,70,72.22,64.62,81.82,72.17,49th
8 2S,60,62.22,54.62,71.82,62.17,39th
9 3N,78.57,83.33,66.67,NR,76.19,74th
10 3S,50,90,50,100,72.5,56th
11 4N,88.89,75,77.27,100,85.29,85th
12 ICU/PCU,72.73,50,80,100,75.68,54th
13
14 St Anthony's Hospital,73.5,73.28,67.89,84.21,74.72,59th
15 Vendor DB % Top Box,72.29,72.86,73.58,75.17,73.48
病院名は実在しますが、興味のあるものであれば偶然です。質問は私が正しいと信じています。場所とデータは架空のものです。
私のコードは CSV ファイルの形式を徹底的にチェックします。作成者がそのようなファイルの形式を警告なしに変更しているのを見つけたからです。大幅な変更はマクロをクラッシュさせる可能性がありますが、マイナーな変更は何ヶ月も気付かれない可能性があります。
チェックには、行 3 の日付範囲と行 6 の特定の日付の照合が含まれます。チェックに失敗すると、エラー ワークシートにメッセージが表示されます。ほとんどのチェックでは、そのファイルが拒否されるだけです。ただし、2 つの CSV ファイルの日付範囲が異なると、致命的なエラーになります。
見つけたデータに基づいて統合ワークシートを作成する予定でした。ただし、絶対アドレスを使用して値をレポート ワークシートにコピーするため、CSV ファイルに含まれる場所に応じてデータが月ごとに移動することは望ましくありません。代わりに、固定レイアウトを作成しました。
病院名は列 1 にあります。名前は、病院の最初の場所に対して指定する必要がありますが、後続の行では省略可能です。いずれかのスタイルを選択することは間違いありませんが、テスト用にスタイルを混合しました. ここに記載されている病院名以外の CSV ファイルは拒否されます。
位置は列 2 にあります。最終行が合計/平均/要約である必要があることを除いて、位置の順序に意味はありません。行のタイトルとして「合計」を使用しましたが、任意に変更できます。ここにリストされているすべての場所が CSV ファイルに表示される必要はありませんが、CSV ファイルに予期しない場所が含まれている場合は拒否されます。
A3から出題されます。ここに記載されていない質問を含む CSV ファイルは拒否されます。
このワークシートのデータ領域の最初の内容は、マクロによってクリアされるため、重要ではありません。
マクロを実行すると、ワークシートは次のようになります。ギャップは、その病院/質問のテストデータがないことを意味します:
コード内のコメントは、私の推測と異なる場合は、CSV ファイルの形式に合わせて変更するのに十分だと思います。
このコードは、独自のモジュールに含まれるように設計されています。このコードは、デモ マクロの何にも依存していません。幸運を。
Option Explicit
' Constants are a convenient way of defining values that will not change
' during a run of the macro. They are particular suitable for:
' (1) Replacing numbers by meaningful name. If column 5 is used for
' names, say, using ColName instead of 5 helps document the macro.
' (2) Values that are used in several places and might change. When they
' do change, one amendment is sufficient to fully update the macro.
Const ColConsolHosp As Long = 1 '\
Const ColConsolLocn As Long = 2 '| If the columns of the consolidate
Const ColConsolQuestFirst As Long = 3 '| worksheet are rearranged, these
Const ColConsolQuestLast As Long = 12 '/ valuesmust be ajusted to match.
Const ColErrorTime As Long = 1
Const ColErrorFile As Long = 2
Const ColErrorRow As Long = 3
Const ColErrorCol As Long = 4
Const ColErrorMsg As Long = 5
Const FmtDate As String = "dmmmyy"
Const FmtDateTime As String = "dmmmyy hh:mm"
Const WkShtNameConsol As String = "Consolidate" '\ Change if require output to
Const WkShtNameError As String = "Error" '/ different worksheets.
Sub Consolidate()
Dim CellValueConsol() As Variant ' Cell values from used range
' of consoldate worksheet
Dim ColSrcCompositeRate As Long ' Column hold composite rate
Dim ColConsolCrnt As Long
Dim DateStartAll As Date
Dim DateStartCrnt As Date
Dim DateEndAll As Date
Dim DateEndCrnt As Date
Dim ErrMsg As String
Dim FileCellValueSrc() As Variant ' Value of UsedRange for each CSV file
Dim FileError() As Boolean ' Error state for each file
Dim FileInxHosp() As Long ' Hospital for each CSV file
Dim FileInxQuest() As Long ' Question for each CSV file
Dim FileName() As String ' Name for each CSV file
Dim FileSysObj As Object
Dim FileObj As Object
Dim FolderObj As Object
Dim Found As Boolean
Dim HospName() As Variant ' Names of hospitals
Dim HospNameCrnt As String
Dim InxFileCrnt As Long
Dim InxFileDate As Long
Dim InxHospCrnt As Long
Dim InxLocnCrnt As Long
Dim InxQuestCrnt As Long
Dim Locn() As Variant ' Locations for each hosital
Dim NumCSVFile As Long ' Number of CSV files
Dim NumHosps As Long
Dim NumMonthsData As Long
Dim PathName As String
Dim Quest As Variant ' Array of questions
Dim RowConsolCrnt As Long
Dim RowConsolHospFirst() As Long ' First row for each hospital
' within consolidate worksheet
Dim RowConsolTemp As Long
Dim RowErrorCrnt As Long
Dim RowSrcCrnt As Long
Dim WkBkSrc As Workbook
Application.ScreenUpdating = False ' Reduces screen flash and increases speed
' Load CSV files
' ==============
PathName = Application.ThisWorkbook.Path
Set FileSysObj = CreateObject("Scripting.FileSystemObject")
Set FolderObj = FileSysObj.GetFolder(PathName)
NumCSVFile = 0
' Loop through files to count number of CSV files
For Each FileObj In FolderObj.Files
If LCase(Right(FileObj.Name, 4)) = ".csv" Then
NumCSVFile = NumCSVFile + 1
End If
Next
' Size arrays holding data per file
ReDim FileCellValueSrc(1 To NumCSVFile)
ReDim FileError(1 To NumCSVFile)
ReDim FileInxHosp(1 To NumCSVFile)
ReDim FileInxQuest(1 To NumCSVFile)
ReDim FileName(1 To NumCSVFile)
InxFileCrnt = 0
' Loop through files to save names and cell values.
For Each FileObj In FolderObj.Files
If LCase(Right(FileObj.Name, 4)) = ".csv" Then
InxFileCrnt = InxFileCrnt + 1
FileName(InxFileCrnt) = FileObj.Name
Set WkBkSrc = Workbooks.Open(PathName & "\" & FileObj.Name)
FileCellValueSrc(InxFileCrnt) = WkBkSrc.ActiveSheet.UsedRange
WkBkSrc.Close ' Close the CSV file
End If
Next
' Release resources
Set FileSysObj = Nothing
Set FolderObj = Nothing
' Extract controlling values from consolidate worksheet
' =====================================================
With Worksheets(WkShtNameConsol)
CellValueConsol = .UsedRange.Value
End With
'Debug.Print UBound(CellValueConsol, 1)
'Debug.Print UBound(CellValueConsol, 2)
' This code assumes a single header row consisting of:
' Hospital Location Question1 Question2 ...
' with appropriate names in the first two columns. The cells under the
' questions will all be overwritten.
' These columns are accessed using constants. Limited variation could
' be achieved within amending the code by changing constants.
' Execution will stop at a Debug.assert statement if the expression has a
' value of False. This is an easy way of confirming the worksheet is as
' expected. If a user might change the format of the output worksheet,
' this should be replaced by a MsgBox statement.
Debug.Assert CellValueConsol(1, ColConsolHosp) = "Hospital"
Debug.Assert CellValueConsol(1, ColConsolLocn) = "Location"
' Count number of hospitals.
' This code assumes all locations for a hospital are together and start at
' row 2. The hospital name may be repeated or may be blank on the second and
' subsequent rows for a hospital. That is, the following is acceptable:
' HospitalA X
' HospitalA Y
' HospitalA Z
' HospitalB X
' Y
' Z
' Count number of hospitals
HospNameCrnt = CellValueConsol(2, ColConsolHosp)
NumHosps = 1
For RowConsolCrnt = 3 To UBound(CellValueConsol, 1)
If CellValueConsol(RowConsolCrnt, ColConsolHosp) <> HospNameCrnt And _
CellValueConsol(RowConsolCrnt, ColConsolHosp) <> "" Then
NumHosps = NumHosps + 1
HospNameCrnt = CellValueConsol(RowConsolCrnt, ColConsolHosp)
End If
Next
'Debug.Print NumHosps
' Size HospName, Locn and RowConsolHospFirst for the number of hospitals
ReDim HospName(1 To NumHosps)
ReDim Locn(1 To NumHosps)
ReDim RowConsolHospFirst(1 To NumHosps)
' Load Hospital and Location arrays
InxHospCrnt = 1
HospNameCrnt = CellValueConsol(2, ColConsolHosp)
HospName(InxHospCrnt) = HospNameCrnt
RowConsolHospFirst(InxHospCrnt) = 2
For RowConsolCrnt = 3 To UBound(CellValueConsol, 1)
If CellValueConsol(RowConsolCrnt, ColConsolHosp) <> HospNameCrnt And _
CellValueConsol(RowConsolCrnt, ColConsolHosp) <> "" Then
' Load locations from worksheet to Location array
Call ExtractSubArray(CellValueConsol, Locn(InxHospCrnt), _
RowConsolHospFirst(InxHospCrnt), ColConsolLocn, _
RowConsolCrnt - 1, ColConsolLocn)
HospNameCrnt = CellValueConsol(RowConsolCrnt, ColConsolHosp)
InxHospCrnt = InxHospCrnt + 1
HospName(InxHospCrnt) = HospNameCrnt
RowConsolHospFirst(InxHospCrnt) = RowConsolCrnt
End If
Next
' Load locations for final hospital from worksheet to Location array
Call ExtractSubArray(CellValueConsol, Locn(InxHospCrnt), _
RowConsolHospFirst(InxHospCrnt), ColConsolLocn, _
UBound(CellValueConsol, 1), ColConsolLocn)
' Load questions
Call ExtractSubArray(CellValueConsol, Quest, _
1, ColConsolQuestFirst, _
1, ColConsolQuestLast)
' Clear data area of Consolidate worksheet
' =======================================
For RowConsolCrnt = 2 To UBound(CellValueConsol, 1)
For ColConsolCrnt = ColConsolQuestFirst To ColConsolQuestLast
CellValueConsol(RowConsolCrnt, ColConsolCrnt) = ""
Next
Next
' Prepare error worksheet
'========================
With Worksheets(WkShtNameError)
.Cells.EntireRow.Delete
.Cells(1, ColErrorTime).Value = "Time"
With .Cells(1, ColErrorFile)
.Value = "File"
.ColumnWidth = 71.71
End With
With .Cells(1, ColErrorRow)
.Value = "Row"
.HorizontalAlignment = xlRight
.ColumnWidth = 4
End With
With .Cells(1, ColErrorCol)
.Value = "Col"
.HorizontalAlignment = xlRight
.ColumnWidth = 4
End With
With .Cells(1, ColErrorMsg)
.Value = "Error"
.ColumnWidth = 71.71
End With
End With
RowErrorCrnt = 1
' Validate the CSV files and extract key information
' ==================================================
InxFileDate = -1 'Date range not yet found
NumMonthsData = 0
For InxFileCrnt = 1 To UBound(FileName)
FileError(InxFileCrnt) = False ' No error found for this file
If IsEmpty(FileCellValueSrc(InxFileCrnt)) Then
' The CSV file was empty
Call RecordError(FileName(InxFileCrnt), 0, 0, _
"Empty CSV file", RowErrorCrnt)
FileError(InxFileCrnt) = True ' This CSV file to be ignored
ElseIf VarType(FileCellValueSrc(InxFileCrnt)) = vbString Then
' The CSV file contained a single value
Call RecordError(FileName(InxFileCrnt), 0, 0, _
"CSV file contains a single string", RowErrorCrnt)
FileError(InxFileCrnt) = True ' This CSV file to be ignored
Else
' The only remaining format that could be returned from a range
' is an array
' Check that cells contain the values expected.
' Most checking code has been placed in subroutines. This keeps the code
' in the main routine clean and simple and allows the subroutines to be
' copied easily to new workbooks with macros performing similar tasks.
' Check Cell A1 = "Caution: Rates Have Not Been Adjusted For Patient Mix"
Call CheckCellValueSingle(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), FileError(InxFileCrnt), _
1, 1, _
"Caution: Rates Have Not Been Adjusted For Patient Mix", _
RowErrorCrnt)
' Check Cell A2 is a known hospital. Save InxHosp against file
Call CheckCellValueMultiple(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), 2, 1, HospName, _
FileInxHosp(InxFileCrnt), RowErrorCrnt)
' Check Cell A3 is: Date - Date Location Comparison Based on N Locations
Call CheckDateRangeLocn(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), 3, 1, _
DateStartCrnt, DateEndCrnt, RowErrorCrnt)
' Save DateStartCrnt and DatEndCrnt or check they are the same as the
' previously saved values
If InxFileDate = -1 Then
' First set of dates
DateStartAll = DateStartCrnt
DateEndAll = DateEndCrnt
InxFileDate = InxFileCrnt ' The first file found with these dates
Else
If DateStartAll = DateStartCrnt And DateEndAll = DateEndCrnt Then
' The date range for this CSV file matches those of previous files
Else
Call RecordError(FileName(InxFileCrnt), 3, 1, _
"**FATAL ERROR**: Date ranges do not match:" & vbLf & _
Format(DateStartAll, FmtDate) & " - " & _
Format(DateEndAll, FmtDate) & " " & _
FileName(InxFileDate) & vbLf & _
Format(DateStartCrnt, FmtDate) & " - " & _
Format(DateEndCrnt, FmtDate) & " " & _
FileName(InxFileCrnt), RowErrorCrnt)
' There are incompatible CSV files. This is a fatal error. Give up.
Exit Sub
End If
End If
' Check Cell A4 = "CMS Qualified HCAHPS Data from All Service Lines"
Call CheckCellValueSingle(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), 4, 1, _
"CMS Qualified HCAHPS Data from All Service Lines", _
RowErrorCrnt)
' Check Cell A5 = Question " Composite Results"
If Not CheckBound(FileCellValueSrc(InxFileCrnt), 5, 1, ErrMsg) Then
Call RecordError(FileName(InxFileCrnt), 5, 1, ErrMsg, RowErrorCrnt)
FileError(InxFileCrnt) = True
Else
FileInxQuest(InxFileCrnt) = -1 ' No match against question
For InxQuestCrnt = 1 To UBound(Quest)
If FileCellValueSrc(InxFileCrnt)(5, 1) = _
Quest(InxQuestCrnt) & " Composite Results" Then
FileInxQuest(InxFileCrnt) = InxQuestCrnt
Exit For
End If
Next
If FileInxQuest(InxFileCrnt) = -1 Then
' No match found
FileError(InxFileCrnt) = True
Call RecordError(FileName(InxFileCrnt), 5, 1, """" & _
FileCellValueSrc(InxFileCrnt)(5, 1) & _
""" does not match a known question", RowErrorCrnt)
End If
End If
' Check cell A6 is: "Location"
Call CheckCellValueSingle(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), 6, 1, "Location", _
RowErrorCrnt)
' Check cells B6 to X6 are the 1st day of month
' from DateStartAll to DateEndAll
Call CheckDateSequence(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), 6, 2, DateStartAll, _
DateEndAll, "a", "m", RowErrorCrnt)
' Check cells Y6 is "Composite Rate"
If Not FileError(InxFileCrnt) Then
' The data range is not guaranteed until the file is error free
NumMonthsData = DateDiff("m", DateStartAll, DateEndAll) + 1
ColSrcCompositeRate = NumMonthsData + 2
Call CheckCellValueSingle(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), 6, ColSrcCompositeRate, _
"Composite Rate", RowErrorCrnt)
End If
If Not FileError(InxFileCrnt) Then
' For row 7 down to the first empty column A, check column A contains
' a known location and ColSrcCompositeRate is numeric.
RowSrcCrnt = 7
InxHospCrnt = FileInxHosp(InxFileCrnt)
Do While True
If Not CheckBound(FileCellValueSrc(InxFileCrnt), _
RowSrcCrnt, 1, ErrMsg) Then
' Row not present
Call RecordError(FileName(InxFileCrnt), RowSrcCrnt, 1, _
ErrMsg, RowErrorCrnt)
FileError(InxFileCrnt) = True
Exit Do
End If
If Not CheckBound(FileCellValueSrc(InxFileCrnt), _
RowSrcCrnt, ColSrcCompositeRate, ErrMsg) Then
' Composite rate missing
Call RecordError(FileName(InxFileCrnt), RowSrcCrnt, _
ColSrcCompositeRate, ErrMsg, RowErrorCrnt)
FileError(InxFileCrnt) = True
Exit Do
ElseIf Not IsNumeric(FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, _
ColSrcCompositeRate)) Then
' Composite rate is not numeric
Call RecordError(FileName(InxFileCrnt), RowSrcCrnt, _
ColSrcCompositeRate, "Composite rate """ & _
FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, _
ColSrcCompositeRate) & """ is not numeric", _
RowErrorCrnt)
End If
If FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, 1) = "" Then
' End of location list within file
Exit Do
End If
Found = False
For InxLocnCrnt = 1 To UBound(Locn(InxHospCrnt))
If FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, 1) = _
Locn(InxHospCrnt)(InxLocnCrnt) Then
' Location from CSV file found in list from consolidate worksheet
Found = True
Exit For
End If
Next
If Not Found Then
Call RecordError(FileName(InxFileCrnt), RowSrcCrnt, 1, _
"Location """ & _
FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, 1) & _
""" not found in list from worksheet """ & _
WkShtNameConsol & """", RowErrorCrnt)
FileError(InxFileCrnt) = True
End If
RowSrcCrnt = RowSrcCrnt + 1
Loop
End If
If Not FileError(InxFileCrnt) Then
' Row RowSrcCrnt will have a blank column 1
RowSrcCrnt = RowSrcCrnt + 1
' Check column A is the total line for the hospital
Call CheckCellValueSingle(FileName(InxFileCrnt), _
FileCellValueSrc(InxFileCrnt), _
FileError(InxFileCrnt), RowSrcCrnt, 1, _
HospName(FileInxHosp(InxFileCrnt)), _
RowErrorCrnt)
If Not CheckBound(FileCellValueSrc(InxFileCrnt), _
RowSrcCrnt, ColSrcCompositeRate, ErrMsg) Then
' Composite rate missing
Call RecordError(FileName(InxFileCrnt), RowSrcCrnt, _
ColSrcCompositeRate, ErrMsg, RowErrorCrnt)
FileError(InxFileCrnt) = True
ElseIf Not IsNumeric(FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, _
ColSrcCompositeRate)) Then
' Composite rate is not numeric
Call RecordError(FileName(InxFileCrnt), RowSrcCrnt, _
ColSrcCompositeRate, "Composite rate """ & _
FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, _
ColSrcCompositeRate) & """ is not numeric", _
RowErrorCrnt)
End If
End If
End If
Next InxFileCrnt
' If get here there has not been a fatal error although one or more
' individual files may have been rejected.
For InxFileCrnt = 1 To UBound(FileName)
If Not FileError(InxFileCrnt) Then
' No error has been found in this file
InxHospCrnt = FileInxHosp(InxFileCrnt)
InxQuestCrnt = FileInxQuest(InxFileCrnt)
ColConsolCrnt = 2 + InxQuestCrnt
RowSrcCrnt = 7 ' First location row
Do While True
If FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, 1) = "" Then
' End of location list within file
Exit Do
End If
For InxLocnCrnt = 1 To UBound(Locn(InxHospCrnt))
If FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, 1) = _
Locn(InxHospCrnt)(InxLocnCrnt) Then
' Location from CSV file found in list from consolidate worksheet
RowConsolCrnt = RowConsolHospFirst(InxHospCrnt) + InxLocnCrnt - 1
CellValueConsol(RowConsolCrnt, ColConsolCrnt) = _
FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, ColSrcCompositeRate)
Exit For
End If
Next
RowSrcCrnt = RowSrcCrnt + 1
Loop
RowSrcCrnt = RowSrcCrnt + 1 ' Advance to hospital total line
' Assume last location row is for total
RowConsolCrnt = RowConsolHospFirst(InxHospCrnt) + _
UBound(Locn(InxHospCrnt)) - 1
CellValueConsol(RowConsolCrnt, ColConsolCrnt) = _
FileCellValueSrc(InxFileCrnt)(RowSrcCrnt, ColSrcCompositeRate)
End If
Next
' Write new values back to consolidate worksheet
' ==============================================
With Worksheets(WkShtNameConsol)
.UsedRange.Value = CellValueConsol
End With
End Sub