WBs to 1 sheet - date problem

[ed8080]

[FONT=Arial, Helvetica, sans-serif]Hi

Hope someone can help....

I have adapted Jerry Beaucaire's "WBs to 1 sheet" merge function (see below) and all is working fine except that I am finding that when the data is imported some of the dates are being changed from UK to US format.

The workbooks to be imported have UK dates in column A in the format 13/08/2011 (ie 13th August 2011) and 12/08/2011 (ie 12th August 2011). The 13th August date imports correctly as 13/08/2011, but the 12th August date imports incorrectly as 08/12/2011 - changing it to the US date format which now translates as 8th December 2011 in the UK.

Thanks.

[/FONT]

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)
'Summary:    Open all Excel files in a specific folder and merge data
'            into one master sheet (stacked)
'            Moves imported files into another folder
Dim fName As String, fPath As String, fPathDone As String, OldDir As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wbkNew As Workbook

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Master").Activate   'sheet report is built into
    
    If MsgBox("Import new data to this report?", vbYesNo) = vbNo Then Exit Sub
    
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        Cells.Clear
        NR = 1
    Else
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    End If

'Path and filename (edit this section to suit)
    MsgBox "Please select a folder with files to consolidate"
    Do
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count > 0 Then
                fPath = .SelectedItems(1) & "\"
                Exit Do
            Else
                If MsgBox("No folder chosen, do you wish to abort?", _
                    vbYesNo) = vbYes Then Exit Sub
            End If
        End With
    Loop
                  'remember final \ in this string
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    OldDir = CurDir                     'memorizes the users current working path
    ChDir fPath                         'activate the filepath with files to import
    fName = Dir("*.xls")                'listing of desired files, edit filter as desired

'Import a sheet from found file
    Do While Len(fName) > 0
        If fName <> wbkNew.Name Then     'make sure this file isn't accidentally reopened
        'Open file
            Set wbData = Workbooks.Open(fName)

        'This is the section to customize, replace with your own action code as needed
        'Find last row and copy data
            
    LR = Range("A" & Rows.Count).End(xlUp).Row
                          'copy the data only
                   
                'If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" And ws.Name <> "Sheet3" Then
                Range("A2:A" & LR).EntireRow.Copy _
                    wbkNew.Sheets("Master").Range("A" & NR)
            
    End If
        'close file
            wbData.Close False
        'Next row
            NR = Range("A" & Rows.Count).End(xlUp).Row + 1
        'move file to IMPORTED folder
            Name fPath & fName As fPathDone & fName
        'ready next filename
            fName = Dir
        'End If
    Loop

ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
    ChDir OldDir                             'restores users original working path
End Sub

[FONT=Arial, Helvetica, sans-serif]
[/FONT]

 

[ed8080]

ok, figured it out. Added following code:

With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & _
               fName, Destination:=Range("A1"))

etc etc.