20.06.2019, 10:23
(Dieser Beitrag wurde zuletzt bearbeitet: 20.06.2019, 10:33 von WillWissen.
Bearbeitungsgrund: Codetags
)
Hallo Leute,
leider komme ich bei meiner VBA nicht weiter. Gerne möchte ich die tägllich gesammelten Daten aus den verschiedensten Tabellen meiner Kollegen an meine Tabelle anhängen und eine Gesamtübersicht erstellen. Es soll also einen öffentlichen Ordner geben in dem jeder seine Daten ablegen kann und ich kopiere sie bei mir rein. Alle Tabellen haben ein identisches Format nur die Zeilen varieren zwischen 50 und 2500. Die fertig übertragenen Tabellen sollten dann automatisch gelöscht werden.
Mein Problem ist, da die Zeilenanzahl variert, sodass ich nicht weiß wie das geschrieben werden muss, das keine Probleme gibt, nachfolgend mein Code:
Danke für eure Hilfe
leider komme ich bei meiner VBA nicht weiter. Gerne möchte ich die tägllich gesammelten Daten aus den verschiedensten Tabellen meiner Kollegen an meine Tabelle anhängen und eine Gesamtübersicht erstellen. Es soll also einen öffentlichen Ordner geben in dem jeder seine Daten ablegen kann und ich kopiere sie bei mir rein. Alle Tabellen haben ein identisches Format nur die Zeilen varieren zwischen 50 und 2500. Die fertig übertragenen Tabellen sollten dann automatisch gelöscht werden.
Mein Problem ist, da die Zeilenanzahl variert, sodass ich nicht weiß wie das geschrieben werden muss, das keine Probleme gibt, nachfolgend mein Code:
Code:
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False) As ADODB.Connection
On Error GoTo LOI:
'Open ADO connection to excel workbook
Dim oConn As ADODB.Connection
Dim Ext As String, ConnStr As String
Set oConn = New ADODB.Connection
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes;"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
LOI:
If Err.Number <> 0 Then
Set oConn = Nothing
If InformErrMSG Then
MsgBox "GetConnXLS" & ": " & Err.Number & " " & Err.Description, vbCritical
End If
End If
End Function
Sub test()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim I As Long
Set cnn = GetConnXLS(ThisWorkbook.Path & "\" & "test.xlsx")
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu"""
Exit Sub
End If
[color=#ff3333] Set rst = cnn.Execute("SELECT * FROM [Tabelle 1$A1:Z2500]")[/color]
Set sh = Sheets("Master")
For I = 0 To rst.Fields.Count - 1
sh.Cells(3, I + 1).Value = rst.Fields(I).Name
Next I
I = sh.Range("A4").CopyFromRecordset(rst)
'sh.Range("A4").CopyFromRecordset rst, tra ve phai co ( )
' I la so dong copy duoc
' den file tiep theo:
'I = I + sh....
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
End Sub
Sub TestOpenFile()
Dim files As Variant
'single file selection
'files = Application.GetOpenFilename()
'MsgBox files
' open multiple files
files = Application.GetOpenFilename(, , , , True)
If VarType(files) = vbBoolean Then Exit Sub
Dim I As Long
For I = LBound(files) To UBound(files)
Next I
Debug.Print VarType(files)
Debug.Print TypeName(files)
End Sub
Sub merge_all()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim I As Long, k As Long, CountFiles As Long, J As Long
Dim files As Variant
files = Application.GetOpenFilename(, , , , True)
If VarType(files) = vbBoolean Then Exit Sub
Set sh = Sheets("Master")
For k = LBound(files) To UBound(files)
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If
[color=#ff3333] Set rst = cnn.Execute("SELECT * FROM [Tabelle 1$A1:Z2500]")[/color]
[color=#ff3333] [/color]
CountFiles = CountFiles + 1
If CountFiles = 1 Then
For J = 0 To rst.Fields.Count - 1
sh.Cells(3, J + 1).Value = rst.Fields(J).Name
Next J
End If
I = I + sh.Range("A" & 4 + I).CopyFromRecordset(rst)
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
Next k
MsgBox "Danke, dass du mithilfst die Datei zu pflegen."
End SubDanke für eure Hilfe
![[-]](https://www.clever-excel-forum.de/images/collapse.png)
