VBA sammenlægning af filer

Lyder interessant.
Er der kun et ark i hver fil ?
Hvis ja, ønsker du så en fil med x antal ark ?

Ja, der er kun ét ark i hver fil.
Filerne skal samles på ét ark i hovedarket.
Det kan selvfølgelig give problemer, hvis der er over 65.536 poster, men det tror jeg nu ikke bliver tilfældet i denne opgave.
Men lad os bare sige, at hvis det er tilfældet, skal der fortsættes på ark2 etc.

En anden detalje, som også kunne være interessant var, at kolonne A på hovedarket indeholdt filnavnet fra detail-filerne.

Eks.:
Detailfilerne indeholder 3 oplysninger: AAA, BBB, CCC som står i henholdsvis kolonne A, B og C.
Hovedarket indeholder så 4 oplysninger:
Kolonne A: Filnavn på detailfil
Kolonne B: Oplysning AAA
Kolonne C: Oplysning BBB
Kolonne D: Oplysning CCC

oki, har en løsningside, der er kvik. vender tilbage senere :-)

Ser jeg frem til :-)
Har egentlig tidligere haft samme problemstilling, men aldrig overvejet, at det måske kunne løses v.h.a. VBA.

Her er en løsningsmodel. Den er ikke optimeret i alle ender og kanter, men er ellers rimelig hurtig.

Forudsætninger:
alle filer i samme bibliotek
alle filer ens i opbygning
alle arknavne er enslydende (kan dog senere tilpasses)
1. række er overskrift.

mangler:
Filnavnet forekommer kun ved 1 record fra hver fil. (kan dog senere tilpasses)

Sub BatchProcess()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Integer
Dim MySheet As String
FilePath = "C:\mytest\"
FileSpec = "*.xls"
MySheet = "Sheet1"
Set FS = Application.FileSearch
With FS
.LookIn = FilePath
.Filename = FileSpec
.Execute
If .FoundFiles.Count = 0 Then
MsgBox ("Ingen filer fundet")
Exit Sub
End If
End With
For i = 1 To FS.FoundFiles.Count
    ThisWorkbook.Worksheets(1).Range("B65536").End(xlUp).Offset(1, -1) = FS.FoundFiles(i)
    GetWorksheetData FS.FoundFiles(i), "SELECT * FROM [" & MySheet & "$];", ThisWorkbook.Worksheets(1).Range("B65536").End(xlUp).Offset(1, 0)
Next
End Sub

Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer, r As Long
    If TargetCell Is Nothing Then Exit Sub
    Set cn = New ADODB.Connection
    On Error Resume Next
    cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DriverId=790;ReadOnly=True;" & _
        "DBQ=" & strSourceFile & ";"
    On Error GoTo 0

    Set rs = New ADODB.Recordset
    On Error Resume Next
    rs.Open strSQL, cn, adOpenStatic, adLockOptimistic, adCmdText
    On Error GoTo 0
   
    TargetCell.CopyFromRecordset rs
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

Det man selv skal udfylde er disse 3 linier

FilePath = "C:\mytest\"
FileSpec = "*.xls"
MySheet = "Sheet1"

Glemte lige at skrive en forudsætning mere....

i vba under tools / references skal der være sat flueben i
Microsoft ActiveX Dataobjects 2.x Library

Så fik jeg testet den, og jeg må sige, at jeg er imponeret ....
Du har gjort det igen Bak :-)

Ud over, at den ikke skriver filnavnet hver gang, og at den kun kan håndtere de 65.536 records, så fungerer det upåklageligt - og hurtigt!

Tak for rosen..
Blev det et problem med de 65536 linier ?
Man kunne jo evt. kode den til at fortsætte på et ny ark

P.t. er det ikke et problem med de 65536 records, men for fuldstændighedens skyld, ville det måske være rart, hvis den fortsatte på sheet2.

Den med fil-navnet ville jeg imidlertid gerne have med, selvom jeg selvfølgelig kunne lave en ekstra kolonne og så indsætte en formel som tjekker om cellen er tom, og så hente senest anvendte filnavn. Det ville dog være nemmere, hvis den var en del af koden. Oplysningen vil jeg gerne have med, så jeg f.eks. kan bruge pivot-tabel funktionen.

Filnavn og sti eller bare filnavn ?

PS.. jeg glemte også at skrive at makroerne kun virker i xl2000 og højere

Ok, jeg er gået væk fra Excel97 nu :-)

Det er fint, hvis det bare er filnavnet.
Resten af stien er jo ens hver gang.

en ændring til den ene sub

Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer, r As Long
Dim JustFileName As String
    If TargetCell Is Nothing Then Exit Sub
    Set cn = New ADODB.Connection
    JustFileName = Mid(strSourceFile, InStrRev(strSourceFile, "\") + 1)
    On Error Resume Next
    cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DriverId=790;ReadOnly=True;" & _
        "DBQ=" & strSourceFile & ";"
    On Error GoTo 0

    Set rs = New ADODB.Recordset
    On Error Resume Next
    rs.Open strSQL, cn, adOpenStatic, adLockOptimistic, adCmdText
    On Error GoTo 0
    TargetCell.CopyFromRecordset rs
    Range(TargetCell.Offset(0, -1), TargetCell.Offset(rs.RecordCount - 1, -1)) = JustFileName
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

Den giver en runtime error i
Range(TargetCell.Offset(0, -1), TargetCell.Offset(rs.RecordCount - 1, -1)) = JustFileName

Ok, her kører den bare, men her er et par forbedringer
I øverste sub er der fjernet en linie of i nedeste en lille fejlsikring.

Den vil stadig fejle hvis du ændrer
GetWorksheetData FS.FoundFiles(i), "SELECT * FROM [" & MySheet & "$];", ThisWorkbook.Worksheets(1).Range("B65536").End(xlUp).Offset(1, 0)
til at referere til kolonne A (man kan ikke offsette -1 kolonne på kolonne A)

Sub BatchProcess()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Integer
Dim MySheet As String
FilePath = "C:\mytest\"
FileSpec = "*.xls"
MySheet = "Sheet1"
Set FS = Application.FileSearch
With FS
    .LookIn = FilePath
    .Filename = FileSpec
    .Execute
    If .FoundFiles.Count = 0 Then
        MsgBox ("Ingen filer fundet")
    Exit Sub
    End If
    For i = 1 To FS.FoundFiles.Count
        GetWorksheetData FS.FoundFiles(i), "SELECT * FROM [" & MySheet & "$];", ThisWorkbook.Worksheets(1).Range("B65536").End(xlUp).Offset(1, 0)
    Next
End With

End Sub

Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer, r As Long
Dim JustFileName As String
    If TargetCell Is Nothing Then Exit Sub
    Set cn = New ADODB.Connection
    JustFileName = Mid(strSourceFile, InStrRev(strSourceFile, "\") + 1)
    On Error Resume Next
    cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DriverId=790;ReadOnly=True;" & _
        "DBQ=" & strSourceFile & ";"
    On Error GoTo 0

    Set rs = New ADODB.Recordset
    On Error Resume Next
    rs.Open strSQL, cn, adOpenStatic, adLockOptimistic, adCmdText
    On Error GoTo 0
    TargetCell.CopyFromRecordset rs
    If rs.RecordCount > 0 Then
        Range(TargetCell.Offset(0, -1), TargetCell.Offset(rs.RecordCount - 1, -1)) = JustFileName
    End If
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

Jeg får kun fejlen, når jeg når over 65.536 rækker.

:-)

efter On Error Goto 0 kunne du jo indsætte

If TargetCell.Row + rs.RecordCount > 65536 Then
        MsgBox " mere end 65536 rækker, nogle data bliver ikke hentet"
        Exit Sub
End If

LOL :-)

Du får dine point for kreativ programmering :-)