Thema Datum  Von Nutzer Rating
Antwort
05.09.2022 15:43:43 Eugen
NotSolved
05.09.2022 17:58:05 Gast15772
NotSolved
05.09.2022 18:20:20 Gast614
NotSolved
05.09.2022 18:25:18 Gast15772
NotSolved
05.09.2022 18:49:04 Trägheit
NotSolved
05.09.2022 18:52:15 Gast15772
NotSolved
05.09.2022 18:55:54 Trägheit
NotSolved
05.09.2022 18:57:59 Gast15772
NotSolved
05.09.2022 19:23:49 Trägheit
NotSolved
05.09.2022 22:00:28 Mase
NotSolved
08.09.2022 18:30:12 Trägheit
NotSolved
08.09.2022 20:24:47 Mase
NotSolved
06.09.2022 08:22:40 volti
NotSolved
05.09.2022 18:17:42 Gast28746
NotSolved
05.09.2022 21:16:18 volti
NotSolved
Blau 32bit auf 64bit Code Excel
06.09.2022 13:30:11 Eugen
NotSolved
10.09.2022 13:13:34 Gast4562
Solved

Ansicht des Beitrags:
Von:
Eugen
Datum:
06.09.2022 13:30:11
Views:
290
Rating: Antwort:
  Ja
Thema:
32bit auf 64bit Code Excel

Hallo Karl-Heinz, 

vielen lieben Dank für deine Überarbeitungen! Das funktioniert jetzt gut und ich kann jetzt das Verzeichnis auswählen, wo die xls Dateien liegen, welche zusammengeführt werden sollen.

Aber leider wird dann nicht hinterher eine neue xls Datei "ausgespuckt", die diese kummulierten Daten zeigt...so wie es in der Vergangenheit war.

Hast jemand hier eine Idee?

Gruss

Eugen

Dies ist der Code dazu

Option Explicit
'Outright (Range zu uebertragen A3:Q55)
'2nd Ring (Range B4:X47)
'Carries (Range A3:W28)
'Options (Range A3:N21)
Dim sPath
Sub ZusammenFuehren()
Dim sDir$, ArFile(), i%
Dim ArTabellen(), ArRange(), ArHeader()
Dim n&, nn&
Dim NewWB As Workbook, rngHelp As Range

ArTabellen = Array("Outright", "2nd Ring", "Carries", "Options")
ArRange = Array("A3:Q63", "B4:X59", "A3:W28", "A3:N21")
ArHeader = Array("A1:Q2", "B1:X3", "A1:W2", "A1:N2")


If sPath = "" Then
    sPath = fncGetFolder(, ThisWorkbook.Path)
Else
    sPath = fncGetFolder(, sPath)
End If
If sPath = "" Then Exit Sub
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

ChDrive sPath
ChDir sPath

sDir = Dir$(sPath & "????-??-??.xlsx", vbNormal)
Do While sDir <> ""
    i = i + 1
    ReDim Preserve ArFile(1 To 2, 1 To i)
    ArFile(1, i) = sPath & sDir
    ArFile(2, i) = sDir
    sDir = Dir$()
Loop

If i > 0 Then
    On Error GoTo ErrorHandler:
    Call Events_(False)
    'neue Mappe
    Set NewWB = Application.Workbooks.Add
    'Tabellen erstellen
    With NewWB
        For n = LBound(ArTabellen) To UBound(ArTabellen)
            NewWB.Worksheets.Add After:=.Sheets(.Sheets.Count)
            .Sheets(.Sheets.Count).Name = ArTabellen(n)
        Next n
        For n = .Sheets.Count - UBound(ArTabellen) - 1 To 1 Step -1
            .Sheets(n).Delete
        Next n
    End With
    
    For i = 1 To UBound(ArFile, 2)
        Application.StatusBar = "File: " & i & " von " & UBound(ArFile, 2) & " - " & ArFile(2, i)
        With Workbooks.Open(ArFile(1, i), ReadOnly:=True)
            For n = LBound(ArTabellen) To UBound(ArTabellen)
                With .Worksheets(ArTabellen(n))
                    
                    If i = 1 Then
                        Set rngHelp = NewWB.Worksheets(ArTabellen(n)).Range(ArHeader(n))
                        .Range(ArHeader(n)).Copy rngHelp
                        rngHelp.Value = rngHelp.Value
                    End If

                    nn = FindLetzte(NewWB.Worksheets(ArTabellen(n)).Columns(.Range(ArHeader(n)).Columns(1).Column)).Row + 1

                    Set rngHelp = NewWB.Worksheets(ArTabellen(n)).Cells(nn, .Range(ArRange(n)).Columns(1).Column)
                    Set rngHelp = rngHelp.Resize(.Range(ArRange(n)).Rows.Count, .Range(ArRange(n)).Columns.Count)
                    .Range(ArRange(n)).Copy rngHelp
                     rngHelp.Value = rngHelp.Value
                     
                     
                    With NewWB.Worksheets(ArTabellen(n))
                        nn = FindLetzte(NewWB.Worksheets(ArTabellen(n)).Columns(.Range(ArRange(n)).Columns(1).Column)).Row + 1
                        .Range(.Cells(nn, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
                        .UsedRange.EntireColumn.AutoFit
                    End With
                    
                End With
            Next n
            .Close False
        End With
    Next i
ErrorHandler:
    Call Events_(True)
    Application.StatusBar = False
End If

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Sub Events_(booschalter As Boolean)
With Application
    .ScreenUpdating = booschalter
    .DisplayAlerts = booschalter
    .EnableEvents = booschalter
    .Calculation = IIf(booschalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub

Function FindLetzte(rngBereich As Range) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
 
With rngBereich
    On Error Resume Next
    'Finde Zeile
    LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
    LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
    If LRow = 0 Then LRow = 1
    LCol = 1
End With

Set FindLetzte = rngBereich.Parent.Cells(LRow, LCol)
End Function


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
05.09.2022 15:43:43 Eugen
NotSolved
05.09.2022 17:58:05 Gast15772
NotSolved
05.09.2022 18:20:20 Gast614
NotSolved
05.09.2022 18:25:18 Gast15772
NotSolved
05.09.2022 18:49:04 Trägheit
NotSolved
05.09.2022 18:52:15 Gast15772
NotSolved
05.09.2022 18:55:54 Trägheit
NotSolved
05.09.2022 18:57:59 Gast15772
NotSolved
05.09.2022 19:23:49 Trägheit
NotSolved
05.09.2022 22:00:28 Mase
NotSolved
08.09.2022 18:30:12 Trägheit
NotSolved
08.09.2022 20:24:47 Mase
NotSolved
06.09.2022 08:22:40 volti
NotSolved
05.09.2022 18:17:42 Gast28746
NotSolved
05.09.2022 21:16:18 volti
NotSolved
Blau 32bit auf 64bit Code Excel
06.09.2022 13:30:11 Eugen
NotSolved
10.09.2022 13:13:34 Gast4562
Solved