слияние данных из csv в excel

[dark7to]

у меня такая задача:
данные из внешних файлов csv (имена файлов любые, нужен перебор всех файлов в папке) нужно слить в один, при импорте установив параметры (кодировка csv "кирилица DOS", разделители только ",", формат ячеек "текст")...
вот код, который выдал excel:

Sub mergeMyData()
'
' mergeMyData Макрос
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\user\1.csv", _
        Destination:=Range("$A$1"))
        .Name = "1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 866
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .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)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

для одного файла и с заданным именем — это работает, а файлов то штук 50 в день...я тупой наверное...умом понимаю, что пути должны быть относительные, что перебор файлов надо осуществить...а как...что...не понимаю...

[Maxx]

Может пригодиться. Данный код писал SAS888. Если данные в csv файле представлены ввиде строк с разделителями (т.е. только в столбце "А", то данный макрос сохранит их в первосданном виде:

Sub Слияние()
    Dim myPath As String, myName As String, fso, tsW
    
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set tsW = fso.OpenTextFile("C:\Documents and Settings\путь к итоговому файлу\имя итогового файла.csv", 2, True) 
       
    myPath = ThisWorkbook.Path & "\" ' файлы, из которых берутся данные, должны лежать в тойже папке, либо надо прописать к ним путь
    
    myName = Dir(myPath & "*.csv")
    Do While myName <> ""
        tsW.Write fso.OpenTextFile(myPath & myName, 1).ReadAll
        myName = Dir
    Loop
    
    tsW.Close
End Sub

[motorway]

Или так:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
 

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("D:\Documents and Settings\My Documents")
Application.EnableEvents = False
    Application.ScreenUpdating = False
       For Each fl In f.Files
    
            If (Right(fl.Name, 4) = ".csv") Then
    
            With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\Documents and Settings\My Documents\" & fl.Name, _
        Destination:=Range("$A$1"))
        .Name = "1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 866
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .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)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        
    End With
 
        End If
        
        Next fl
Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[dark7to]

motorway, большое спасибо, вот только что то у меня опять не получается...
он гад их в строчку забивает...опять я чего то не понял...
вот пример:
в исходных файлах

(первый)
и

(второй)
должно быть (в итоге)

а получается

на всякий случай:

Sub mergeMyData()
'
' mergeMyData Макрос
'

'
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("C:\TEMP\reestr")
Application.EnableEvents = False
    Application.ScreenUpdating = False
       For Each fl In f.Files
    
            If (Right(fl.Name, 4) = ".csv") Then
    
         With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\TEMP\reestr\" & fl.Name, _
        Destination:=Range("$A$1"))
        .Name = "1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 866
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .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)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        
    End With
 
        End If
        
        Next fl
Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

в чем косяк? где я напортачил?

[motorway]

Попробуйте так (работает при начальной загрузке, при повторном нажатии сдвигает - т.е., если действие однократно происходит - то нормально работает):

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
 

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("D:\Documents and Settings\Konstantin\My Documents")
Application.EnableEvents = False
    Application.ScreenUpdating = False


     i = 0
       For Each fl In f.Files

            If (Right(fl.Name, 4) = ".csv") Then
i = i + 1
            With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\Documents and Settings\Konstantin\My Documents\" & fl.Name, _
        Destination:=Cells(i, 1))
        .Name = "1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 866
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
 
           
        End If
        
        
        Next fl
Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[dark7to]

УРРА!!! разницу понял...и все заработало...большое спасибо, не дали пропасть...спасли...