Using Type Record Structures In Excel VBA
The following code demonstrates how to create data structures in Excel using the Type statement.
Program Code
Option Explicit ' ************************************************ ' Workbook/Worksheet Assignments ' ************************************************ Dim wkbAdagioImportTemplate As Workbook Dim wksAdagioImportData As Worksheet Dim wksAdagioItemNumberTranslation As Worksheet Dim wkbNexternalExport As Workbook Dim wksNexternalOrders As Worksheet Dim wksNexternalLineItems As Worksheet Dim wksNexternalCustomers As Worksheet Dim strFilePathToRawData As String Dim strImportedNexternalWorkbook As String Dim dlgOpenFile As FileDialog Dim lngLastRowOfOrders As Long Dim lngLastRowOfLineItems As Long Dim lngLastRowOfCustomers As Long Dim lngAdagioTemplateActiveRow As Long Dim lngLastRowOfItemNumberTranslation As Long Dim strLastOrder As String Dim strSaveAsName As String Dim i As Long Dim d As Long Dim C As Range Dim rngItemNumberTranslation As Range Public Type AdagioRecordTypeH strRecordType As String strCustomerNumber As String strOrderNumberWithPreamble As String strOrderNumber As String dteDate As Date strShippingMethod As String strTrackingNumber As String strDropShip As String strOrderNote As String strState As String strTransactionID As String dblTotalInvoiceAmount As Double End Type Type AdagioRecordTypeS strRecordType As String strContact As String strCompanyName As String strStreetAddress1 As String strStreetAddress2 As String strCityState As String strZipCode As String strPhoneNumber As String End Type Type AdagioRecordTypeM strRecordType As String strShippingIndicator As String dblShippingCharge As Double End Type Type AdagioRecordTypeD strRecordType As String strItemNumber As String lngQuantityOrdered As Long dblPriceEach As Double End Type Public Sub ConvertNexternalToAdagio() Dim TypeH As AdagioRecordTypeH Dim TypeS As AdagioRecordTypeS Dim TypeM As AdagioRecordTypeM Dim TypeD As AdagioRecordTypeD Set wkbAdagioImportTemplate = ThisWorkbook Set wksAdagioImportData = wkbAdagioImportTemplate.Sheets("AdagioImport") Set wksAdagioItemNumberTranslation = wkbAdagioImportTemplate.Sheets("ItemNumberTranslation") wksAdagioImportData.Range(wksAdagioImportData.Cells(1, 1), wksAdagioImportData.Cells(30000, 50)).ClearContents lngAdagioTemplateActiveRow = 0 ' ******************************************************* ' Open Nexternal Export Data ' ******************************************************* strFilePathToRawData = "" Set dlgOpenFile = Application.FileDialog(msoFileDialogOpen) With dlgOpenFile .Title = "Select Nexternal Export Excel File" .AllowMultiSelect = False .Filters.Clear .Filters.Add "Excel File", "*.xlsx" .FilterIndex = 1 .Show If .SelectedItems.Count < 1 Then MsgBox ("No File Selected") Exit Sub End If strFilePathToRawData = .SelectedItems(1) End With ' ************************************************ ' Check for Valid Path - If Valid then save ' The Workbook Name and Open It ' ************************************************ If strFilePathToRawData = "" Then MsgBox ("No File Selected") Exit Sub End If Workbooks.Open strFilePathToRawData ' ************************************************ ' Register the External Workbook To Be Imported ' ************************************************ Set wkbNexternalExport = ActiveWorkbook Set wksNexternalOrders = wkbNexternalExport.Sheets("Orders") Set wksNexternalLineItems = wkbNexternalExport.Sheets("Line Items") Set wksNexternalCustomers = wkbNexternalExport.Sheets("Customers") strImportedNexternalWorkbook = ActiveWorkbook.Name ' ************************************************ ' Validate the correct workbook was opened ' ************************************************ If wksNexternalLineItems.Cells(1, 1) <> "ORDER_NO" Then MsgBox ("File Format Does Not Agree With Expected Format" & vbCrLf & "Import Cancelled") wkbNexternalExport.Close SaveChanges:=False Exit Sub End If ' ************************************************ ' Locate Last Orders Record ' ************************************************ lngLastRowOfOrders = wksNexternalOrders.Cells(wksNexternalOrders.Rows.Count, "A").End(xlUp).Row ' ************************************************ ' Locate Last Line Item Record ' ************************************************ lngLastRowOfLineItems = wksNexternalLineItems.Cells(wksNexternalLineItems.Rows.Count, "A").End(xlUp).Row ' ************************************************ ' Locate Last Customers Record ' ************************************************ lngLastRowOfCustomers = wksNexternalCustomers.Cells(wksNexternalCustomers.Rows.Count, "A").End(xlUp).Row ' ************************************************ ' Locate Last Row Of Item Number Translation ' ************************************************ lngLastRowOfItemNumberTranslation = wksAdagioItemNumberTranslation.Cells(wksAdagioItemNumberTranslation.Rows.Count, "A").End(xlUp).Row ' ************************************************ ' Set Search Range For Item Number Translation ' ************************************************ Set rngItemNumberTranslation = Range(wksAdagioItemNumberTranslation.Cells(2, 1), wksAdagioItemNumberTranslation.Cells(lngLastRowOfItemNumberTranslation, 1)) ' ************************************************ ' Loop Through Each Order ' ************************************************ Application.ScreenUpdating = False For i = 2 To lngLastRowOfOrders ' ************************************************************************************************ ' Format H Record ' ************************************************************************************************ strLastOrder = wksNexternalOrders.Cells(i, 1) TypeH.strRecordType = "H" TypeH.strCustomerNumber = GetCustomerNumber(wksNexternalOrders.Cells(i, "D")) TypeH.strOrderNumberWithPreamble = "Nexternal " & wksNexternalOrders.Cells(i, "A") TypeH.strOrderNumber = wksNexternalOrders.Cells(i, "A") TypeH.dteDate = wksNexternalOrders.Cells(i, "B") TypeH.strShippingMethod = GetShippingMethod(strLastOrder) TypeH.strTrackingNumber = GetTrackingNumber(strLastOrder) TypeH.strDropShip = "No" TypeH.strOrderNote = wksNexternalOrders.Cells(i, "AJ") TypeH.strState = GetState(strLastOrder) TypeH.strTransactionID = String(31, "X") & wksNexternalOrders.Cells(i, "X") TypeH.dblTotalInvoiceAmount = wksNexternalOrders.Cells(i, "H") lngAdagioTemplateActiveRow = lngAdagioTemplateActiveRow + 1 Call FormatAdagioHRecord wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A") = TypeH.strRecordType wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B") = TypeH.strCustomerNumber wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C") = TypeH.strOrderNumberWithPreamble wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "D") = TypeH.strOrderNumber wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "E") = TypeH.dteDate wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "F") = TypeH.strShippingMethod wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "G") = TypeH.strTrackingNumber wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "H") = TypeH.strDropShip wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "I") = TypeH.strOrderNote wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "J") = TypeH.strState wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "K") = TypeH.strTransactionID wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "L") = TypeH.dblTotalInvoiceAmount ' ************************************************************************************************ ' Format S Record ' ************************************************************************************************ TypeS.strRecordType = "S" TypeS.strContact = GetContact(strLastOrder) TypeS.strCompanyName = GetCompanyName(strLastOrder) TypeS.strStreetAddress1 = GetStreetAddress1(strLastOrder) TypeS.strStreetAddress2 = GetStreetAddress2(strLastOrder) TypeS.strCityState = GetCityState(strLastOrder) TypeS.strZipCode = GetZipCode(strLastOrder) TypeS.strPhoneNumber = GetPhoneNumber(strLastOrder) lngAdagioTemplateActiveRow = lngAdagioTemplateActiveRow + 1 Call FormatAdagioSRecord wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A") = TypeS.strRecordType wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B") = TypeS.strContact wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C") = TypeS.strCompanyName wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "D") = TypeS.strStreetAddress1 wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "E") = TypeS.strStreetAddress2 wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "F") = TypeS.strCityState wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "G") = TypeS.strZipCode wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "H") = TypeS.strPhoneNumber ' ************************************************************************************************ ' Format M Record ' ************************************************************************************************ TypeM.strRecordType = "M" TypeM.strShippingIndicator = "1" TypeM.dblShippingCharge = GetShippingCharge(strLastOrder) lngAdagioTemplateActiveRow = lngAdagioTemplateActiveRow + 1 Call FormatAdagioMRecord wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A") = TypeM.strRecordType wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B") = TypeM.strShippingIndicator wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C") = TypeM.dblShippingCharge ' ************************************************************************************************ ' Format D Records ' ************************************************************************************************ For d = 2 To lngLastRowOfLineItems If strLastOrder <> CStr(wksNexternalLineItems.Cells(d, "A")) Then GoTo GetNextItem End If If Left(wksNexternalLineItems.Cells(d, "B"), 9) = "Sales Tax" Or _ Left(wksNexternalLineItems.Cells(d, "B"), 8) = "Shipping" Then GoTo GetNextItem End If TypeD.strRecordType = "D" TypeD.strItemNumber = GetAdagioItemNumber(wksNexternalLineItems.Cells(d, "C")) TypeD.lngQuantityOrdered = wksNexternalLineItems.Cells(d, "E") TypeD.dblPriceEach = wksNexternalLineItems.Cells(d, "D") lngAdagioTemplateActiveRow = lngAdagioTemplateActiveRow + 1 Call FormatAdagioDRecord wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A") = TypeD.strRecordType wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B") = TypeD.strItemNumber wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C") = TypeD.lngQuantityOrdered wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "D") = TypeD.dblPriceEach GetNextItem: Next d ' ************************************************************************************************ ' Get Next Order Number ' ************************************************************************************************ Next i wkbAdagioImportTemplate.Activate wkbNexternalExport.Close SaveChanges:=False ' ******************************************************** ' Save the CSV File With A Unique Date and Time Stamp ' ******************************************************** strSaveAsName = CurDir() & "\" & "AdagioImportFileFromNexternal_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00") Application.DisplayAlerts = False wksAdagioImportData.Copy ActiveWorkbook.SaveAs Filename:=strSaveAsName, FileFormat:=xlCSV ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox ("The Report Was Saved to " & strSaveAsName) End Sub Private Function GetCustomerNumber(strCustomerNumber) As String Dim j As Long For j = 2 To lngLastRowOfCustomers If strCustomerNumber = CStr(wksNexternalCustomers.Cells(j, "A")) Then GetCustomerNumber = wksNexternalCustomers.Cells(j, "AA") Exit Function End If Next j GetCustomerNumber = "NotFound" End Function Private Function GetShippingMethod(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetShippingMethod = wksNexternalLineItems.Cells(j, "AA") Exit Function End If Next j GetShippingMethod = "NotFound" End Function Private Function GetTrackingNumber(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetTrackingNumber = wksNexternalLineItems.Cells(j, "AG") Exit Function End If Next j GetTrackingNumber = "NotFound" End Function Private Function GetState(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetState = wksNexternalLineItems.Cells(j, "W") Exit Function End If Next j GetState = "NotFound" End Function Private Function GetContact(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetContact = wksNexternalLineItems.Cells(j, "O") & ", " & wksNexternalLineItems.Cells(j, "P") Exit Function End If Next j GetContact = "NotFound" End Function Private Function GetCompanyName(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetCompanyName = wksNexternalLineItems.Cells(j, "S") Exit Function End If Next j GetCompanyName = "NotFound" End Function Private Function GetStreetAddress1(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetStreetAddress1 = wksNexternalLineItems.Cells(j, "T") Exit Function End If Next j GetStreetAddress1 = "NotFound" End Function Private Function GetStreetAddress2(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetStreetAddress2 = wksNexternalLineItems.Cells(j, "U") Exit Function End If Next j GetStreetAddress2 = "NotFound" End Function Private Function GetCityState(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetCityState = wksNexternalLineItems.Cells(j, "V") & ", " & wksNexternalLineItems.Cells(j, "W") Exit Function End If Next j GetCityState = "NotFound" End Function Private Function GetZipCode(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then GetZipCode = wksNexternalLineItems.Cells(j, "X") Exit Function End If Next j GetZipCode = "NotFound" End Function Private Function GetPhoneNumber(strOrderNumber) As String Dim j As Long For j = 2 To lngLastRowOfLineItems If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then If wksNexternalLineItems.Cells(j, "R") = "" Then GetPhoneNumber = CStr(wksNexternalLineItems.Cells(j, "Q")) Exit Function Else GetPhoneNumber = CStr(wksNexternalLineItems.Cells(j, "Q")) & " X" & CStr(wksNexternalLineItems.Cells(j, "R")) Exit Function End If End If Next j GetPhoneNumber = "NotFound" End Function Private Function GetShippingCharge(strOrderNumber) As String Dim j As Long Dim k As Long For j = 2 To lngLastRowOfLineItems ' ************************************************ ' Locate the first matching order number in the ' stream of transactions, and then search within ' that matching stream until a shipping charge ' is found ' ************************************************ If strOrderNumber = CStr(wksNexternalLineItems.Cells(j, "A")) Then k = j Do If Left(wksNexternalLineItems.Cells(k, "B"), 8) = "Shipping" Then GetShippingCharge = wksNexternalLineItems.Cells(k, "F") Exit Function End If k = k + 1 Loop Until strOrderNumber <> CStr(wksNexternalLineItems.Cells(k, "A")) GetShippingCharge = "NotFound" Exit Function End If Next j GetShippingCharge = "NotFound" End Function Private Sub FormatAdagioHRecord() wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "D").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "E").NumberFormat = "YYYY-MM-DD" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "F").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "G").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "H").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "I").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "J").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "K").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "L").NumberFormat = "0.00" End Sub Private Sub FormatAdagioSRecord() wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "D").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "E").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "F").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "G").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "H").NumberFormat = "@" End Sub Private Sub FormatAdagioMRecord() wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C").NumberFormat = "0.00" End Sub Private Sub FormatAdagioDRecord() wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "A").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "B").NumberFormat = "@" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "C").NumberFormat = "0" wksAdagioImportData.Cells(lngAdagioTemplateActiveRow, "D").NumberFormat = "0.00" End Sub Private Function GetAdagioItemNumber(ItemNumber As String) As String For Each C In rngItemNumberTranslation If ItemNumber = C.Value Then GetAdagioItemNumber = C.Offset(0, 1).Value Exit Function End If Next C GetAdagioItemNumber = ItemNumber End Function