how to update this VBA so that it checks the new data columns against old data columns?

I have this code below.

it imports the selected worksheet into Target worksheet called "Maria Hospital"

now the number of columns with data and their order and also header names of the existing data in the target worksheet and the new imported file must match. if any of them do not match. macro should pop a message box stating which column header or order changed, or if new column added.

how can this code be modified, that before clearing the target old data via this line
    If Not IsEmpty(ClearRng) = True Then
        ClearRng.ClearContents    
    End If

Open in new window


The macro should do a cross examination of columns between the existing data and the new data that is to be imported and if column header or order of columns changed, or if new column added to the end of data. it should pop a message box.


thanks.

Sub UpdatefromFileofOracle()
Dim TargetWs As Worksheet, SourceWs As Worksheet
Dim TargetLR As Long, TargetLC As Long, SourceLR As Long, SourceLC As Long, zl As Long
Dim FolderPath As String, Filter As String, Caption As String, SourceFName As Variant
Dim SourceWB As Workbook, TargetWB As Workbook
Dim ClearRng As Range, CopyRng As Range

FolderPath = Application.ThisWorkbook.Path
ChDir FolderPath
Filter = "Excel files (*.xl*),*.xl*"
Caption = "Please Browse & Select the downloaded File "
SourceFName = Application.GetOpenFilename(Filter, , Caption)

If SourceFName = False Then
    MsgBox "You have CANCELLED selection of needed FILE", vbCritical, "- FOLLOW INSTRUCTION"
    Exit Sub
Else

Set SourceWB = Application.Workbooks.Open(SourceFName, Format:=xlDelimited, Local:=True)

    'Disable Events
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .DisplayStatusBar = True
        .StatusBar = "!!! Please Be Patient...Updating Records !!!"
        .EnableEvents = False
        .Calculation = xlManual
    End With
    
    'Clear Old Data
    Set TargetWB = Application.ThisWorkbook
    Set TargetWs = TargetWB.Worksheets("Maria Hospital")
    TargetLR = TargetWs.Range("A1").SpecialCells(xlCellTypeLastCell).Row
    TargetLC = TargetWs.Range("A1").SpecialCells(xlCellTypeLastCell).Column
    Set ClearRng = TargetWs.Range(TargetWs.Range("A1"), TargetWs.Cells(TargetLR, TargetLC))
    
    If Not IsEmpty(ClearRng) = True Then
        ClearRng.ClearContents    
    End If

    'Copy Data From Source Workbook
  Set lo = Nothing
  
     For zl = 1 To SourceWB.Sheets.Count
        Set SourceWs = SourceWB.Sheets(zl)
        If SourceWs.Visible Then Exit For
    Next
    
    On Error Resume Next
    Set lo = SourceWs.ListObjects(1)
    On Error GoTo 0
    If Not lo Is Nothing Then
        Set CopyRng = lo.Range
    Else
        SourceLR = SourceWs.Range("A1").SpecialCells(xlCellTypeLastCell).Row
        SourceLC = SourceWs.Range("A1").SpecialCells(xlCellTypeLastCell).Column
        Set CopyRng = SourceWs.Range(SourceWs.Range("A1"), SourceWs.Cells(SourceLR, SourceLC))
    End If
    

    CopyRng.Copy
    TargetWs.Range("A1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    
    ' Close Source Workbook
    Application.DisplayAlerts = False
    SourceWB.Close SaveChanges:=False
    
    TargetWs.Activate
    TargetWs.Columns.AutoFit
    TargetWs.Rows.AutoFit
    TargetWs.Cells.WrapText = False
    On Error Resume Next
    TargetWs.ListObjects(1).Unlist
    On Error GoTo 0
    TargetWs.Range("A1").Select
    
    
    'Enable Events
    With Application
         .DisplayAlerts = False
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .StatusBar = False
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
    MsgBox "!!! File Import Is Completed Now !!!"
End If
End Sub

Open in new window

LVL 6
FloraAsked:
Who is Participating?
 
Bill PrewCommented:
Give this a try.

Sub UpdatefromFileofOracle()
Dim TargetWs As Worksheet, SourceWs As Worksheet
Dim TargetLR As Long, TargetLC As Long, SourceLR As Long, SourceLC As Long, zl As Long
Dim FolderPath As String, Filter As String, Caption As String, SourceFName As Variant
Dim SourceWB As Workbook, TargetWB As Workbook
Dim ClearRng As Range, CopyRng As Range
Dim HeadersMatch

FolderPath = Application.ThisWorkbook.Path
ChDir FolderPath
Filter = "Excel files (*.xl*),*.xl*"
Caption = "Please Browse & Select the downloaded File "
SourceFName = Application.GetOpenFilename(Filter, , Caption)

If SourceFName = False Then
    MsgBox "You have CANCELLED selection of needed FILE", vbCritical, "- FOLLOW INSTRUCTION"
    Exit Sub
Else

Set SourceWB = Application.Workbooks.Open(SourceFName, Format:=xlDelimited, Local:=True)

    'Disable Events
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .DisplayStatusBar = True
        .StatusBar = "!!! Please Be Patient...Updating Records !!!"
        .EnableEvents = False
        .Calculation = xlManual
    End With
    
    ' Select source worksheet
    For zl = 1 To SourceWB.Sheets.Count
        Set SourceWs = SourceWB.Sheets(zl)
        If SourceWs.Visible Then Exit For
    Next
    
    'Clear Old Data
    Set TargetWB = Application.ThisWorkbook
    Set TargetWs = TargetWB.Worksheets("Maria Hospital")
    TargetLR = TargetWs.Range("A1").SpecialCells(xlCellTypeLastCell).Row
    TargetLC = TargetWs.Range("A1").SpecialCells(xlCellTypeLastCell).Column
    
    ' Make sure headers match
    SourceLR = SourceWs.Range("A1").SpecialCells(xlCellTypeLastCell).Row
    SourceLC = SourceWs.Range("A1").SpecialCells(xlCellTypeLastCell).Column
    HeadersMatch = True
    If TargetLC = SourceLC Then
        For i = 1 To TargetLC
            If TargetWs.Cells(1, i).Value <> SourceWs.Cells(1, i).Value Then
                HeadersMatch = False
            End If
        Next
    Else
        HeadersMatch = False
    End If
    If HeadersMatch = False Then
        MsgBox "Headers in import file do not match existing data, can not import."
        SourceWB.Close SaveChanges:=False
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = True
            .DisplayStatusBar = True
            .StatusBar = False
            .EnableEvents = True
            .Calculation = xlAutomatic
        End With
        Exit Sub
    End If
    
    Set ClearRng = TargetWs.Range(TargetWs.Range("A1"), TargetWs.Cells(TargetLR, TargetLC))
    
    If Not IsEmpty(ClearRng) = True Then
        ClearRng.ClearContents
    End If

    'Copy Data From Source Workbook
    Set lo = Nothing
  
    On Error Resume Next
    Set lo = SourceWs.ListObjects(1)
    On Error GoTo 0
    If Not lo Is Nothing Then
        Set CopyRng = lo.Range
    Else
        Set CopyRng = SourceWs.Range(SourceWs.Range("A1"), SourceWs.Cells(SourceLR, SourceLC))
    End If
    

    CopyRng.Copy
    TargetWs.Range("A1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    
    ' Close Source Workbook
    Application.DisplayAlerts = False
    SourceWB.Close SaveChanges:=False
    
    TargetWs.Activate
    TargetWs.Columns.AutoFit
    TargetWs.Rows.AutoFit
    TargetWs.Cells.WrapText = False
    On Error Resume Next
    TargetWs.ListObjects(1).Unlist
    On Error GoTo 0
    TargetWs.Range("A1").Select
    
    
    'Enable Events
    With Application
         .DisplayAlerts = False
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .StatusBar = False
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
    MsgBox "!!! File Import Is Completed Now !!!"
End If
End Sub

Open in new window


»bp
0
 
FloraAuthor Commented:
Thank you very much Bill.  much appreciated.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.