help needed on VBA modification on earlier solution by Bill

I had this question after viewing how to update this VBA so that it checks the new data columns against old data columns?.


Bill was so kind to help me with the modification code below.

i was wondering if it is easy to modify the code, so that message box mentions what has changed? whether column order moved, or new column added or columnheader name changed.

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
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

LVL 6
FloraAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Bill PrewCommented:
In the real data, what does the header row look like?  Can you paste a sample?  I'm wondering how large it is.

The simplest way to do this would just be to display the two header rows in the MsgBox, it will be harder to identify a particular column since there are a lot of ways they could be different.  But if the header row is 100 cells with long text in them it might not work to display all...


»bp
0
Bill PrewCommented:
Couldn't test this here, but give it a try, might give you what you need, or at least a template you can adjust as you prefer...

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 = ""
    If TargetLC = SourceLC Then
        For i = 1 To TargetLC
            If TargetWs.Cells(1, i).Value <> SourceWs.Cells(1, i).Value Then
                HeadersMatch = "Header column mismatch at column = " & i & "exiting = " & TargetWs.Cells(1, i).Value & ", import = " & SourceWs.Cells(1, i).Value
                Exit For
            End If
        Next
    Else
        HeadersMatch = "Header column count differs, existing count = " & SourceLC & ", import count = " & TargetLC
    End If
    If HeadersMatch <> "" Then
        MsgBox "Headers in import file do not match existing data, can not import." & vbCrLf & cbCrLf & HeadersMatch
        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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:
Bill, you nailed it.

thanks very much. you are genius!
0
FloraAuthor Commented:
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.