Question

我想通过使用WorkbookConnection.AddfromFile将csv文件与excels power pivot与VBA代码连接

我的问题：

我想连接多个csv文件。为此，我必须通过文本导入向导单击几个小时。我还没有发现如何自动化这个！我想用类似的方式来做，就像我在我的代码上部用FileDialog做的那样。在我想要实现它的代码部分下面。

For LoopCounter = 1 To fd.SelectedItems.count
    ActiveWorkbook.Connections.AddFromFile _
        fd.SelectedItems(LoopCounter), True, False
Next LoopCounter

在我已编写的代码下面。使用此代码，我必须手动单击TextImportWizard。

Sub csv()

Dim fd As FileDialog
Dim ActionClicked As Boolean
Dim LoopCounter As Long

Set fd = Application.FileDialog(msoFileDialogFilePicker)

fd.InitialFileName = "C:\temp"
fd.AllowMultiSelect = True
fd.Title = "Open your data"
fd.ButtonName = "GO"

ActionClicked = fd.Show

If ActionClicked Then

    For LoopCounter = 1 To fd.SelectedItems.count

        ActiveWorkbook.Connections.AddFromFile _
        fd.SelectedItems(LoopCounter), True, False

    Next LoopCounter

Else

    MsgBox "You didn't choose anything"
    Exit Sub

End If

End Sub

Answer 1

导入CSV或文本文件的更快方法是使用以下

Dim SortStr As Variant
Dim SortNum As Long

'change below array as per your requirement
SortStr = Array("Open", "in progress", "almost finished")   
Application.AddCustomList ListArray:=SortStr
SortNum = Application.CustomListCount

ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Range("B1"), xlSortOnValues, xlAscending, SortNum
ActiveSheet.Sort.SortFields.Add Range("A1"), xlSortOnValues, xlDescending
With ActiveSheet.Sort
    .SetRange Range(Data)
    .Header = xlGuess
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Application.DeleteCustomList Application.CustomListCount

如果你想为文件夹中的所有CSV文件自动化它，我建议你循环浏览档案 - 查看.csv文件 - 这里有一个关于如何开始使用的示例：

Dim InputStringCSV As String
Dim CSVFile As Variant
Dim ArrayStringCSV() As String
CSVFile = Application.GetOpenFilename("CSV Files,*.CSV", Title:="MyData")
 If CSVFile = False Then "No input!", vbCritical: End
 Open CSVFile For Input As #1
  Do Until EOF(1)
        Line Input #1, InputStringCSV
        ArrayStringCSV = Split(InputStringCSV, Chr(10))
        For CounterArray = LBound(ArrayStringCSV) To UBound(ArrayStringCSV)
        'Defaults: Row 1 is the beginnning for the sheet
            Sheets(Sheet_CSV).Cells(1 + CounterArray, 1).NumberFormat = "@"
            Sheets(Sheet_CSV).Cells(1 + CounterArray, 1) = ArrayStringCSV(CounterArray)
        Next CounterArray
    Loop
    Close #1

Answer 2

有很多方法可以导入文本文件。请参阅以下链接。

http://www.rondebruin.nl/win/s3/win022.htm

此AddIn将为您完成工作。

http://www.rondebruin.nl/win/addins/rdbmerge.htm

此外，您可以将文件夹中的所有文本文件合并到一个工作表中。

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long

    Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#Else
    Private Declare Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long

    Private Declare Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#End If


Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
    Dim hProg As Long
    Dim hProcess As Long, ExitCode As Long
    'fill in the missing parameter and execute the program
    If IsMissing(WindowState) Then WindowState = 1
    hProg = Shell(PathName, WindowState)
    'hProg is a "process ID under Win32. To get the process handle:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
    Do
        'populate Exitcode variable
        GetExitCodeProcess hProcess, ExitCode
        DoEvents
    Loop While ExitCode = STILL_ACTIVE
End Sub


Sub Merge_CSV_Files()
    Dim BatFileName As String
    Dim TXTFileName As String
    Dim XLSFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim DefPath As String
    Dim Wb As Workbook
    Dim oApp As Object
    Dim oFolder
    Dim foldername

    'Create two temporary file names
    BatFileName = Environ("Temp") & _
            "\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
    TXTFileName = Environ("Temp") & _
            "\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"

    'Folder where you want to save the Excel file
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Set the extension and file format
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007 or higher
        FileExtStr = ".xlsx": FileFormatNum = 51
        'If you want to save as xls(97-2003 format) in 2007 use
        'FileExtStr = ".xls": FileFormatNum = 56
    End If

    'Name of the Excel file with a date/time stamp
    XLSFileName = DefPath & "MasterCSV " & _
                  Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr

    'Browse to the folder with CSV files
    Set oApp = CreateObject("Shell.Application")
    Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
    If Not oFolder Is Nothing Then
        foldername = oFolder.Self.Path
        If Right(foldername, 1) <> "\" Then
            foldername = foldername & "\"
        End If

        'Create the bat file
        Open BatFileName For Output As #1
        Print #1, "Copy " & Chr(34) & foldername & "*.csv" _
                & Chr(34) & " " & TXTFileName
        Close #1

        'Run the Bat file to collect all data from the CSV files into a TXT file
        ShellAndWait BatFileName, 0
        If Dir(TXTFileName) = "" Then
            MsgBox "There are no csv files in this folder"
            Kill BatFileName
            Exit Sub
        End If

        'Open the TXT file in Excel
        Application.ScreenUpdating = False
        Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
                :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
                Space:=False, Other:=False

        'Save text file as a Excel file
        Set Wb = ActiveWorkbook
        Application.DisplayAlerts = False
        Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
        Application.DisplayAlerts = True

        Wb.Close savechanges:=False
        MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName

        'Delete the bat and text file you temporary used
        Kill BatFileName
        Kill TXTFileName

        Application.ScreenUpdating = True
    End If
End Sub

你会在这里找到更多信息。

http://www.rondebruin.nl/win/s3/win021.htm

如何使用VBA自动添加WorkbookConnections？

2 个答案: