Snasui Excel Forum

Code: Select all

Sub ImportdbfFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim dbffilesToOpen As Variant, dbffile As Variant
    Dim x As Long
    On Error Resume Next

    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Dbf Files (*.dbf), *.dbf", _
                  MultiSelect:=True, Title:="àÅ×Í¡ä¿Åì·Õèµéͧ¡ÒùÓà¢éÒ by...")
    If VarType(dbffilesToOpen) = vbBoolean Then
        MsgBox "¡ÃسÒàÅ×Í¡ä¿Åì·Õè¨Ð¹Óà¢éÒ", , "by..."
        Exit Sub
    End If

    For Each dbffile In dbffilesToOpen

        For Each xlsheet In ThisWorkbook.Worksheets
        
            If LCase(xlsheet.Name) = LCase(fso.GetBaseName(dbffile)) Then

                xlsheet.Activate
                GoTo ImportData
            End If
        Next xlsheet


        Set xlsheet = ThisWorkbook.Worksheets.Add( _
                             After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        xlsheet.Name = Replace(fso.GetFileName(dbffile), ".dbf", "")
        xlsheet.Activate
        GoTo ImportData

ImportData:

        ActiveSheet.Range("A:Z").EntireColumn.Delete xlShiftToLeft


        With ActiveSheet.QueryTables.Add(Connection:="DBF;" & dbffile, _
          Destination:=ActiveSheet.Cells(3, 1))
          
        .Name = "DataSheet"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .AdjustColumnWidth = True
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
        .Refresh BackgroundQuery:=False
        End With
        
        'For x = 1 To 100
        'UpdateProgressBar x, 100
    'Next x

    ActiveSheet.Range("A3").AutoFilter Field:=1, Visibledropdown:=True
    ActiveSheet.Range("A3").AutoFilter Field:=2, Visibledropdown:=True
    Application.ErrorCheckingOptions.NumberAsText = False

       Cells.Select
        Selection.NumberFormat = "0"
    
        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next qt
    Next dbffile

    Application.ScreenUpdating = True
    MsgBox "¹Óà¢éÒ¢éÍÁÙÅÊÓàÃç¨áÅéÇ", vbInformation, "ÊÓàÃç¨áÅéÇ"
    
    Sheets(1).Activate

    Set fso = Nothing
    
     On Error Resume Next
    For Each sht In ThisWorkbook.Worksheets
      xlsheet.Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
      
    'Application.ScreenUpdating = False
        'With ActiveWindow
        '.DisplayGridlines = True
        '.DisplayHeadings = True
    'End With
    'Application.ScreenUpdating = True
      
    Next sht
  On Error GoTo 0
    

End Sub

Code: Select all

Sub ImportdbfFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim dbffilesToOpen As Variant, dbffile As Variant
    Dim x As Long, wb As Workbook
'    On Error Resume Next

    
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Dbf Files (*.dbf), *.dbf", _
                  MultiSelect:=True, Title:="àÅ×Í¡ä¿Åì·Õèµéͧ¡ÒùÓà¢éÒ by...")
    If VarType(dbffilesToOpen) = vbBoolean Then
        MsgBox "¡ÃسÒàÅ×Í¡ä¿Åì·Õè¨Ð¹Óà¢éÒ", , "by..."
        Exit Sub
    End If

'    For Each dbffile In dbffilesToOpen
    For i = LBound(txtfilesToOpen) To UBound(txtfilesToOpen)
        For Each xlsheet In ThisWorkbook.Worksheets
        
'            If LCase(xlsheet.Name) = LCase(fso.GetBaseName(dbffile)) Then
            If LCase(xlsheet.Name) = LCase(fso.GetBaseName(txtfilesToOpen(i))) Then
                xlsheet.Activate
                GoTo ImportData
            End If
        Next xlsheet

        ' ÊÃéÒ§ sheet ãËÁè ¶éÒäÁ辺 sheet ·Õèµéͧ¡ÒÃ
        Set xlsheet = ThisWorkbook.Worksheets.Add( _
                             After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        xlsheet.Name = Replace(fso.GetFileName(dbffile), ".dbf", "")
        xlsheet.Activate
        GoTo ImportData

ImportData:
        ActiveSheet.Range("A:Z").EntireColumn.Delete xlShiftToLeft
        Set wb = Workbooks.Open(txtfilesToOpen(i))
        wb.Worksheets(1).UsedRange.Copy ThisWorkbook.ActiveSheet.Cells(3, 1)
'        With ActiveSheet.QueryTables.Add(Connection:=txtfilesToOpen(i), _
'          Destination:=ActiveSheet.Cells(3, 1))
'
'        .Name = "DataSheet"
'        .FieldNames = True
'        .RowNumbers = False
'        .FillAdjacentFormulas = False
'        .PreserveFormatting = True
'        .RefreshOnFileOpen = False
'        .AdjustColumnWidth = True
'        .TextFilePromptOnRefresh = False
'        .TextFilePlatform = 65001
'        .TextFileStartRow = 1
'        .TextFileParseType = xlDelimited
'        .TextFileTextQualifier = xlTextQualifierDoubleQuote
'        .TextFileConsecutiveDelimiter = False
'        .TextFileTabDelimiter = True
'        .TextFileSemicolonDelimiter = False
'        .TextFileCommaDelimiter = False
'        .TextFileSpaceDelimiter = False
'        .TextFileOtherDelimiter = "|"
'        .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
'        .Refresh BackgroundQuery:=False
'        End With
        
        'For x = 1 To 100
        'UpdateProgressBar x, 100
    'Next x
    ThisWorkbook.Activate
    ActiveSheet.Range("A3").AutoFilter Field:=1, Visibledropdown:=True
    ActiveSheet.Range("A3").AutoFilter Field:=2, Visibledropdown:=True
    Application.ErrorCheckingOptions.NumberAsText = False

       Cells.Select
        Selection.NumberFormat = "0"
    
'        For Each qt In ActiveSheet.QueryTables
'            qt.Delete
'        Next qt
'    Next dbffile
    wb.Close False
    Next i
    Application.ScreenUpdating = True
    MsgBox "¹Óà¢éÒ¢éÍÁÙÅÊÓàÃç¨áÅéÇ", vbInformation, "ÊÓàÃç¨áÅéÇ"
    
    Sheets(1).Activate

    Set fso = Nothing
    
     On Error Resume Next
    For Each sht In ThisWorkbook.Worksheets
      xlsheet.Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
      
    'Application.ScreenUpdating = False
        'With ActiveWindow
        '.DisplayGridlines = True
        '.DisplayHeadings = True
    'End With
    'Application.ScreenUpdating = True
      
    Next sht
  On Error GoTo 0
    

End Sub