Thema Datum  Von Nutzer Rating
Antwort
Rot VBA - Tabellenblätter von anderer Datei übertragen
26.07.2022 18:34:05 Vanessa
NotSolved
26.07.2022 19:42:11 ralf_b
NotSolved

Ansicht des Beitrags:
Von:
Vanessa
Datum:
26.07.2022 18:34:05
Views:
76
Rating: Antwort:
  Ja
Thema:
VBA - Tabellenblätter von anderer Datei übertragen

Guten Tag,

1. ich möchte von Excel Datei "Rechnungen1", die aus 23 Tabellenblätter ("Tabelle1,Tabelle2...immer von Zeile 5 bis Zeile 1800 bzw die letzte Zeile mit Werten (Spaltenbreite bis AN) besteht, die kopieren und untereinander zusammen in ein vorhandenes Tabellenblatt "Master" /eine neue Datei "Rechnungszusammenfassung" einfügen.

Hier bräucht ich eine Hilfestellung.

2. Was ich bisher habe ist folgender Code, der aber nicht sonderlich gut funktionieren will. Will ich den Code in eine andere Exceldatei einfügen, bekomme ich immer den Fehler: "Fehler beim Kompilieren. Benutzerdefinierter Typ nicht definiert"(Ja er soll in andere Dateien, da dort sehr viele Formeln hinterlegt sind die auf den ersten Sheet mit "Master" gesteuert sind. Ein großen Vorteil hat der Code->Man kann ihn auf verschiedene "Rechnungen"-Dateien anwenden (solange die Arbeitsblätter gleich heißen). Denn es sollen verschiedene Rechnungen unabhängig voneinander aktualisiert und ausgewertet werden.

 

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 xml;HDR=Yes"";"

oConn.Open ConnStr
Set GetConnXLS = oConn
Exit Function

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 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, strData, _
        kDS As Long, xKorr As Integer
    files = Application.GetOpenFilename(, , , , True)
    
    If VarType(files) = vbBoolean Then Exit Sub
    Set sh = Sheets("Master")
    
    For k = LBound(files) To UBound(files)
        'Anzahl der Datensätze in der ausgewählten DAtei ermitteln
        kDS = lastRowClosedFile(files(k), "Master", "A:A")
        
        'ADODB-Connection erstellen
        Set cnn = GetConnXLS(files(k))
        If cnn Is Nothing Then
            MsgBox "Check lai co so du lieu file: " & files(k)
            Exit Sub
        End If
        
        'Select-Befehl zusammenstellen
        strData = "SELECT * From [Tabelle1$A5:AN" & kDS & "];"
        'Recordset öffnen auf der Grundlage der Connection & Select-Befehl
        Set rst = cnn.Execute(strData)
        
        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
        If k = 1 Then
           xKorr = 1
        Else
           xKorr = 0
        End If
        sh.Range("I" & 4 + I - xKorr).Value = files(k)
        I = I + sh.Range("A" & 4 + I).CopyFromRecordset(rst)
        
        rst.Close
        Set rst = Nothing
        cnn.Close
        Set cnn = Nothing
        
    Next k
    MsgBox "Done", vbSystemModal + 48, "Hurraaa..."
End Sub











Function lastRowClosedFile(ByVal FileName As String, SheetName As String, TargetRange As String) As Long
  Dim objADO As Object
  
  On Error Resume Next
  
  Set objADO = ExcelTable(FileName, SheetName, TargetRange)
  lastRowClosedFile = objADO.RecordCount + 1
  objADO.Close
  
End Function


Private Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String) As Object
  Dim SQL As String
  Dim Con As String
  
  SQL = "select * from [" & Table & "$" & SourceRange & "]"
  
  If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
    Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Extended Properties=Excel 8.0;" _
      & "Data Source=" & Path & ";"
  ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
    Con = "Provider=Microsoft.ACE.OLEDB.12.0;" _
      & "Extended Properties=""Excel 12.0;HDR=YES"";" _
      & "Data Source=" & Path & ";"
  Else
    Exit Function
  End If
  Set ExcelTable = CreateObject("ADODB.Recordset")
  ExcelTable.Open SQL, Con, 3, 1
End Function

 

 

Falls mir jemand helfen kann, dem wäre ich sehr Dankbar.

 

Grüßle

Vanessa


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot VBA - Tabellenblätter von anderer Datei übertragen
26.07.2022 18:34:05 Vanessa
NotSolved
26.07.2022 19:42:11 ralf_b
NotSolved