Kann man 30 oder mehr Tabellen in einem Schlag in

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Udo!
Wenn sich ausschliesslich die Dateien mit den Addressen in einem Ordner befinden und die Tabellen in diesen Dateien alle den selben Namen tragen, dann gehts mit folgendem Code.
Einfach in einer neuen Datei in ein allgemeines Modul einfügen, die kommentierten Angaben anpassen und starten.
(Alt+F11 &gt "Einfügen" &gt "Modul" &gt in das rechte Fenster den Code kopieren &gt mit F5 den Code startetn)

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DatenZusammenfuehren()
Dim objFS As FileSearch
Dim objSh As Worksheet
Dim strPath As String, strSheet
Dim intIndex As Integer, intC As Integer
Dim lngR As Long
Dim vVar() As Variant

On Error GoTo ErrExit
GetMoreSpeed

strPath = "F:\Temp\Ext" ' Verzeichnis mit den Dateien ' Anpassen!

strSheet = "Tabelle1" ' Name der Tabelle mit den Adressen ' Anpassen!

lngR = 2

With ThisWorkbook
  Set objSh = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
End With

objSh.Name = "Import " & Format(Now, "dd_mm_yy hhmmss")

Set objFS = Application.FileSearch

With objFS
  .NewSearch
  .LookIn = strPath
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = False

  If .Execute > 0 Then

    For intIndex = 1 To .FoundFiles.Count

      With ExcelTable(.FoundFiles(intIndex), strSheet, "A1:H1000")
        If intIndex = 1 Then
          For intC = 1 To .fields.Count
            objSh.Cells(1, intC) = .fields(intC - 1).Name
          Next
          objSh.Rows(1).Font.Bold = True
        End If

        vVar = .GetRows
        vVar = TransposeDim(vVar)
        objSh.Range(objSh.Cells(lngR, 1), objSh.Cells(lngR + UBound(vVar, 1) - 1, 8)) = vVar
        .Close
      End With
      lngR = lngR + UBound(vVar, 1)
    Next

  End If

End With

objSh.Columns.AutoFit

ErrExit:

If Err Then
  MsgBox Err.Number & vbLf & Err.Description, 64, "Fehler"
End If

GetMoreSpeed 0

Set objFS = Nothing
Set objSh = Nothing

End Sub

Public Function ExcelTable(ByVal Path As String, ByVal Table As String, ByVal SourceRange As String) As Object
Dim SQL As String
Dim Con As String

SQL = "select * from [" & Table & "$" & SourceRange & "]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
  & "Extended Properties=Excel 8.0;" _
  & "Data Source=" & Path & ";"
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
End Function

Private Function TransposeDim(Field As Variant, Optional Base1 As Boolean = True) As Variant
Dim lngX1 As Long, lngY1 As Long, lngX2 As Long, lngY2 As Long
Dim varTmp As Variant

lngX2 = UBound(Field, 2) + IIf(Base1, 1, 0)
lngY2 = UBound(Field, 1) + IIf(Base1, 1, 0)

If Base1 Then
  Redim varTmp(1 To lngX2, 1 To lngY2)
  For lngX1 = 1 To lngX2
    For lngY1 = 1 To lngY2
      varTmp(lngX1, lngY1) = Field(lngY1 - 1, lngX1 - 1)
    Next
  Next
Else
  Redim varTmp(lngX2, lngY2)
  For lngX1 = 0 To lngX2
    For lngY1 = 0 To lngY2
      varTmp(lngX1, lngY1) = Field(lngY1, lngX1)
    Next
  Next
End If

TransposeDim = varTmp

End Function

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Kann man 30 oder mehr Tabellen in einem Schlag in

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kann man 30 oder mehr Tabellen in einem Schlag in

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread