(Solved) – VBA – Find columns with a specific headers that may be spelled differently


Good evening. I am developing a subroutine for a project whereby the user is able to upload specific data from a separate workbook into the master. The routine will search through the chosen excel file for specific column headers and only copy/paste those desired columns to the master sheet. This is my first coding project and I think I have the process mostly sorted, however there is one bit of functionality that is eluding me: The specific column titles are moderately similar no matter the workbook, except they may vary between full name and abbreviation. For example the title of the column may be “AZM” or it may be “Azimuth”. Alternatively one column title may be “N/S”, “Northing” or “NS”. There will never be multiple of these titles, just the one in the format that the workbook creator decided to go with.

My current code does not currently account for that:

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
    Dim wb As Workbook
    Dim filename As String, colName As String
    Dim LRow As Long, LCol As Long
    Dim pColName As String, MyHead(1 To 8) As String
    Dim sCell As Range, PRng As Range
    Dim col As Long, pCol As Long

    MsgBox "Ensure plan includes MD/INC/AZM/TVD/NS/EW/VS/DLS"
    With Application.FileDialog(msoFileDialogOpen)                                                                          'Open file explorer

        .AllowMultiSelect = False                                                                                           'Only allow one file to be chosen
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1                                                      'Limit selection options to excel files

        If .Show Then

            filename = .SelectedItems(1)                                                                                    'Assign file path to variable filename

            Set wb = Workbooks.Open(filename:=filename)                                                                     'Set selected Excel file to variable wb

            MyHead(1) = "MD"
            MyHead(2) = "Inc"
            MyHead(3) = "Azimuth"
            MyHead(4) = "TVD"
            MyHead(5) = "N/S"
            MyHead(6) = "E/W"
            MyHead(7) = "VS"
            MyHead(8) = "DLS"

            If Not IsEmpty(ThisWorkbook.Worksheets("5D-Lite").Range("M33")) Then
                LRow = Cells(Rows.Count, 13).End(xlUp).Row                                                                  'Find the last row of data in column M from previous plan
                LCol = Cells(LRow, Columns.Count).End(xlToLeft).Column                                                      'Find the last column of data in the last row
                ThisWorkbook.Worksheets("5D-Lite").Range("M33:" & Col_Letter(LCol) & LRow).ClearContents                    'Clear the contents of the range determined by the Last functions
            End If

            With wb.Worksheets(1)
                For i = LBound(MyHead) To UBound(MyHead)
                    Set sCell = .Range("A1:R50").Find(What:=MyHead(i), LookIn:=xlValues, LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)                                           'Search for the desired directional plan items in column headers

                    If Not sCell Is Nothing Then
                        col = sCell.Column                                                                                  'Located item's column number
                        pCol = i   12                                                                                       'Column number in master workbook to paste in
                        colName = Split(.Cells(, col).Address, "$")(1)                                                      'Located item's column letter
                        pColName = Split(.Cells(, pCol).Address, "$")(1)                                                    'Column letter in master workbook to paste in
                        LRow = FindLastNumeric()                                                                            'Find the final row with numeric data
                        Set PRng = .Range(sCell.Address & ":" & colName & LRow)                                             'Set total data range of desired column

                        wb.Worksheets(1).Range(PRng.Address).Copy ThisWorkbook.Worksheets("5D-Lite").Range(pColName & "32") 'Copy contents of selected file to the 5D sheet
                    End If
                Range("M32:T" & LRow   33).NumberFormat = "0.00"                                                            'Assigns numeric formatting to the pasted data range
                wb.Close SaveChanges:=False
                Set wb = Nothing
            End With

        MsgBox "No Plan Selected"
        End If
    End With
Application.ScreenUpdating = True
End Sub

Is there any way to modify the .Find function or the MyHead(i) variables to account for multiple possible variations on the same header name? Thanks for any ideas.

Leave a Reply

Your email address will not be published. Required fields are marked *