Thema Datum  Von Nutzer Rating
Antwort
20.04.2017 18:59:29 Excel_glücklos
Solved
20.04.2017 19:01:32 Excel_glücklos
NotSolved
Rot Konsolidierung Arbeitsblätter verschiedener Dateien
20.04.2017 21:53:20 BigBen
NotSolved
20.04.2017 22:44:11 Gast7279
NotSolved
21.04.2017 11:51:30 BigBen
Solved

Ansicht des Beitrags:
Von:
BigBen
Datum:
20.04.2017 21:53:20
Views:
769
Rating: Antwort:
  Ja
Thema:
Konsolidierung Arbeitsblätter verschiedener Dateien

Hallo,

es mussten folgende Änderungen vorgenommen werden:

1
2
3
4
With Tabelle1.Range("A1")
    .Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$C:$C<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$C:$C))-9"
    lngLZ = .Value
End With

In der Formula Zeile muss die Angabe $A:$A nach $C:$C geändert werden.

Zusätzlich müssen die ersten 9 Zeilen abgezogen werden. Daher "-9" am Ende.

1
2
3
4
5
6
7
8
If blnÜberschrift Then
    .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _
    "='" & sPfad & "[" & sDatei & "]Tabelle1'!C11"
Else
    blnÜberschrift = True
    .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
    "='" & sPfad & "[" & sDatei & "]Tabelle1'!C10"
End If

In diesem Bereich müssen nur zwei Änderungen vorgenommen werden:

Daten: 'Tabelle1'!A2 muss nach 'Tabelle1'!C11 geändert werden

Überschrift: 'Tabelle1'!A1 muss nach 'Tabelle1'!C10 geändert werden.

Der neue Code schaut nach den Änderungen wie folgt aus:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
Sub Zusammenführen()
    Dim i               As Long
    Dim sPfad           As String
    Dim sDatei          As String
    Dim vFileToOpen     As Variant
    Dim lngLZ           As Long
    Dim blnÜberschrift  As Boolean
    Dim iCalc           As Integer
     
     
    vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
    If Not IsArray(vFileToOpen) Then Exit Sub
     
         
    iCalc = Application.Calculation
 
    On Error GoTo ENDE:
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
     
     
    For i = 1 To UBound(vFileToOpen)
        sDatei = Dir(vFileToOpen(i))
        sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1)
     
        With Tabelle1.Range("A1")
            .Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$C:$C<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$C:$C))-9"
            lngLZ = .Value
        End With
         
        With Tabelle1
            If blnÜberschrift Then
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!C11"
            Else
                blnÜberschrift = True
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!C10"
            End If
        End With
         
        Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
    Next
     
    With Tabelle1.UsedRange
        .Copy
        .PasteSpecial xlPasteValues
        .Rows(1).Delete
    End With
     
ENDE:
    Application.EnableEvents = True
    Application.Calculation = iCalc
    Application.ScreenUpdating = True
    If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub
 
Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100)
    Dim Mess, Z, Rest
    Static oldStatusBar As Integer
    Static blnInit As Boolean
 
    If Not blnInit Then
        oldStatusBar = Application.DisplayStatusBar
        Application.DisplayStatusBar = True
    End If
     
    Mess = ""
    For Z = 1 To ProzentSatz
        Mess = Mess & ChrW(Val("&H25A0"))
    Next Z
    Rest = 100 - ProzentSatz
    For Z = 1 To Rest
        Mess = Mess & ChrW(Val("&H25A1"))
    Next Z
    Application.StatusBar = Mess & " " & ProzentSatz & "%"
     
    If Rest <= 0 Then
        Application.StatusBar = False
        Application.DisplayStatusBar = oldStatusBar
    End If
End Sub

Während der Ausführung ist mir aufgefallen, dass nur die ersten 5 Überschriften importiert werden, obwohl in den Daten 30 Überschriften vorhanden sind.

LG, BigBen


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
20.04.2017 18:59:29 Excel_glücklos
Solved
20.04.2017 19:01:32 Excel_glücklos
NotSolved
Rot Konsolidierung Arbeitsblätter verschiedener Dateien
20.04.2017 21:53:20 BigBen
NotSolved
20.04.2017 22:44:11 Gast7279
NotSolved
21.04.2017 11:51:30 BigBen
Solved