Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit

Excel Makro Hilfe - Makro zum Zusammenfassen von Zeilen mehrerer Dateien

Frage Microsoft Microsoft Office

Mitglied: trdshimo

trdshimo (Level 1) - Jetzt verbinden

17.01.2013 um 18:45 Uhr, 3104 Aufrufe, 12 Kommentare

Hallo Liebe Community ;)

Ich bin gerade dabei ein Makro zu schreiben, welches wie folgt funktionieren soll.

Ein angegebenes Verzeichnis, soll nach *.XLS Dateien durchsucht werden. Anschließend sollen alle gefundenen Excel Dateien ausgelesen werden. Hier soll immer das gleiche Tabellenblatt und die gleiche Zeile ausgelesen werden und in eine "GesamtDatei" untereinander geschrieben werden.

Folgendes Makro habe ich bereits gefunden, welches auch soweit ganz gut funktioniert, jedoch habe ich ein Problem es auf das Bestimmte Tabellenblatt und die bestimmte Zeile anzupassen anzupassen.

Die auszuelsene Zeile wäre 2:2
Der Name des Tabellenblattes ist "Werte"

Das Ganze soll immer in das Tabelleblatt "Data" der Gesamtdatei ausgelesen werden.

01.
Sub GetData() 
02.
 
03.
Sheets("Data").Select 
04.
Set oMe = ThisWorkbook.ActiveSheet 'Data (= die aktuelle Tabelle der aktuellen Datei) 
05.
Const sDateiPfad As String = "C:\test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende 
06.
 
07.
sZeile = "2:2" 'auszulesende Zeile 
08.
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen 
09.
iSpalte = 2 'ab Spalte A in Zieltabelle eintragen 
10.
 
11.
Set oFS = CreateObject("Scripting.FileSystemObject") 
12.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files 
13.
    sWbName = oDatei.Name 
14.
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then 
15.
        Workbooks.Open (sDateiPfad & sWbName) 
16.
 
17.
        Sheets("Werte").Select 
18.
        oMe.Cells(iZeile, iSpalte).Value = Workbooks(sWbName).ActiveSheet.Range(sZeile).Value 
19.
        oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte - 1), Address:=sDateiPfad & sWbName, TextToDisplay:=sDateiPfad & sWbName 
20.
        Workbooks(sWbName).Saved = True 
21.
        Workbooks(sWbName).Close 
22.
        iZeile = iZeile + 1 
23.
    End If 
24.
Next 
25.
End Sub

Da ich das Makro von einem vorhandenen Makro umgeschrieben habe (und dies höchstwahrscheinlich falsch getan habe), erhalte ich aktuell einen "Laufzeitfehler 1004". Die Bemerkungen sind noch aus dem alten Makro welches ich hier im Forum gefunden habe (http://www.administrator.de/frage/excel-dateien-durchsuchen-und-werte-i ...)

Dies war das Ausgangs Makro:

01.
Sub GetData() 
02.
 
03.
Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen Datei) 
04.
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende 
05.
 
06.
sZelle1 = "H5" 'auszulesende Zelle 
07.
sZelle2 = "D5" 'weitere auszulesende Zelle 
08.
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen 
09.
iSpalte = 1 'ab Spalte A in Zieltabelle eintragen 
10.
 
11.
Set oFS = CreateObject("Scripting.FileSystemObject") 
12.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files 
13.
    sWbName = oDatei.Name 
14.
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then 
15.
        Workbooks.Open (sDateiPfad & sWbName) 
16.
        oMe.Cells(iZeile, iSpalte).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle1).Value 
17.
        oMe.Cells(iZeile, iSpalte + 1).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle2).Value 
18.
        oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte + 2), Address:=sDateiPfad & sWbName, TextToDisplay:=sWbName 
19.
        Workbooks(sWbName).Saved = True 
20.
        Workbooks(sWbName).Close 
21.
        iZeile = iZeile + 1 
22.
    End If 
23.
Next 
24.
End Sub
Ich denke das ich einfach zu blöd bin und die Lösung ziemlich einfach ist :P

Kann mir jemand Helfen? Vielen Dank im voraus!

M.f.G.
Mitglied: bastla
17.01.2013, aktualisiert um 22:09 Uhr
Hallo trdshimo und willkommen im Forum!

Da Du nicht genau angibst, ob in den Quelltabellen jeweils nur Werte oder doch auch Formeln stehen, werden im folgenden Ansatz auf jeden Fall Werte übertragen (und ggf Formeln durch ihr Ergebnis ersetzt):
01.
Sub GetData() 
02.
Const sDateiPfad As String = "C:\test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende 
03.
Const sTabQuelle As String = "Werte" 'Tabellenname in den Quelldateien 
04.
Const sTabZiel As String = "Data" 'Tabellenname in der Zieldatei 
05.
sZeile = "2:2" 'auszulesender Bereich (ganze Zeile 2) 
06.
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen 
07.
 
08.
Set oMe = ThisWorkbook.Sheets(sTabZiel) 
09.
 
10.
Set oFS = CreateObject("Scripting.FileSystemObject") 
11.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files 
12.
    sWbName = oDatei.Name 
13.
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then 
14.
        Workbooks.Open (sDateiPfad & sWbName) 'Quelldatei öffnen 
15.
        Sheets(sTabQuelle).Range(sZeile).Copy 'Quellbereich (Zeile 2) kopieren und ... 
16.
        oMe.Rows(iZeile).PasteSpecial xlPasteValues '... in Zieldatei nur Werte einfügen 
17.
        oMe.Cells(iZeile, 1).Copy 'Dummy, um Frage nach "großer Menge von Informationen in der Zwischenablage" zu vermeiden 
18.
        Workbooks(sWbName).Saved = True 
19.
        Workbooks(sWbName).Close 
20.
        iZeile = iZeile + 1 'Zeilennummer füür Zieldatei erhöhen 
21.
    End If 
22.
Next 
23.
End Sub
Grüße
bastla
Bitte warten ..
Mitglied: trdshimo
18.01.2013 um 09:09 Uhr
Hallo bastla,

erst einmal vielen Dank für die Begrüßung und natürlich vor allem für die Hilfe.

Ich habe dein Vorgeschlagenes Makro noch einmal um den Hyperlink erweitert, bekomme aber (auch ohne Hyperlink) den Fehler
"Laufzeitfehler '9': Index außerhalb des gültigen Bereichs"

Also für mich sichtbar ist:
- in meiner "GesamtDatei" wechselt er wie gewollt auf das Blatt "DataBase", dann öffnet er die erste File aus dem angegebenen Verzeichnis und stoppt mit dem Laufzeitfehler. Hat es hier irgendetwas damit zu tun, das das zu öffnende Sheet Schreibgeschützt geöffnet wird?

So sieht es nun aktuell aus:
01.
Sub GetData() 
02.
Const sDateiPfad As String = "C:\Test" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende 
03.
Const sTabQuelle As String = "Tabelle3" 'Tabellenname in den Quelldateien 
04.
Const sTabZiel As String = "DataBase" 'Tabellenname in der Zieldatei 
05.
sZeile = "4:4" 'auszulesender Bereich 
06.
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen 
07.
 
08.
Set oMe = ThisWorkbook.Sheets(sTabZiel) 
09.
 
10.
Set oFS = CreateObject("Scripting.FileSystemObject") 
11.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files 
12.
    sWbName = oDatei.Name 
13.
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then 
14.
        Workbooks.Open (sDateiPfad & sWbName) 'Quelldatei öffnen 
15.
        Sheets(sTabQuelle).Range(sZeile).Copy 'Quellbereich (Zeile 2) kopieren und ... 
16.
        oMe.Rows(iZeile).PasteSpecial xlPasteValues '... in Zieldatei nur Werte einfügen 
17.
        oMe.Cells(iZeile, 1).Copy 'Dummy, um Frage nach "großer Menge von Informationen in der Zwischenablage" zu vermeiden 
18.
        oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte - 1), Address:=sDateiPfad & sWbName, TextToDisplay:=sDateiPfad & sWbName 'Hyperlink 
19.
        Workbooks(sWbName).Saved = True 
20.
        Workbooks(sWbName).Close 
21.
        iZeile = iZeile + 1 'Zeilennummer für Zieldatei erhöhen 
22.
    End If 
23.
Next 
24.
End Sub
Noch einmal Vielen Dank an dich!

M.f.G.
Bitte warten ..
Mitglied: bastla
18.01.2013, aktualisiert um 10:12 Uhr
Hallo trdshimo!

Aufgrund der Fehlermeldung würde ich vermuten, dass es keine Tabelle mit dem Namen "Tabelle3" gibt ...

Hinsichtlich des Hyperlinks noch eine Anmerkung: Da es keine Variable "iSpalte" mehr gibt (hatte ich als unnötig gesehen, da ja eine ganze Zeile eingefügt wird) kann die Zeile 18 so ohnehin nicht funktionieren, und das "- 1" wäre vermutlich auch zu überdenken - daher besser gleich die Spalte für den Hyperlink unmittelbar (ohne Berechnung) angeben (entweder mittels einer Konstanten / Variablen, die Du am Anfang des Makros einfügst oder zur Not auch einfach durch Eintrag der Spalte in die Zeile 18).

Grüße
bastla

P.S.: Spannend finde ich, wie sich in kurzer Zeit Tabellennamen (ehemals "Werte") und Zeilennummern (gestern noch 2) ändern können ...
Bitte warten ..
Mitglied: trdshimo
18.01.2013, aktualisiert um 10:18 Uhr
Hallo bastla,

in den Excel Datein befindet sich zu 100% ein Sheet mit dem Namen "Tabelle3" ich habe dies noch ein paar mal gegengeprüft und auch die Namen auf beispeilsweise "tab3" geändert, das Ergebnis ist hier leider der gleiche Laufzeitfehler.

Hast du vlt. noch eine Idee?

Zitat von bastla:
P.S.: Spannend finde ich, wie sich in kurzer Zeit Tabellennamen (ehemals "Werte") und Zeilennummern (gestern noch 2)
ändern können ...

hrhr, dies habe ich nur gemacht um ein bisschen rumzutesten ;)


Vielen Dank!

Mit freundlichen Grüßen
Bitte warten ..
Mitglied: bastla
18.01.2013 um 11:25 Uhr
Hallo trdshimo!

In welcher Zeile tritt denn der Fehler auf?

Grüße
bastla
Bitte warten ..
Mitglied: trdshimo
18.01.2013, aktualisiert um 12:40 Uhr
Hey bastla,

also wenn ich das Makro mit F8 durchgehe erscheint der Fehler nach Zeile 15

sprich:
01.
Sheets(sTabQuelle).Range(sZeile).Copy 'Quellbereich (Zeile 2) kopieren und ...
Vielen Dank!
Bitte warten ..
Mitglied: bastla
18.01.2013, aktualisiert um 13:17 Uhr
Hallo trdshimo!

Sorry - das lässt weiterhin keinen anderen Schluss zu, als dass das Blatt nicht gefunden wird - ev ein Leerzeichen vor oder nach dem Namen der Tabelle?

Wenn Du sicher bist (oder auch nur, um den Rest testen zu können ), dass es immer um das 3. Blatt der Mappe geht, könntest Du in Zeile 3 anstelle des Namens "Tabelle3" auch die Zahl 3 verwenden (dann aber natürlich nicht mit "As String" - den Typ kannst Du auch weglassen) ...
In Zeile 2 fehlt übrigens am Ende des Pfades der Backslash.
Eine sinnvolle Ergänzung (wenn auch eher nur für die Optik) wäre noch, unmittelbar vor "End Sub" eine Zeile
Application.CutCopyMode = False
einzufügen.

Grüße
bastla
Bitte warten ..
Mitglied: trdshimo
18.01.2013, aktualisiert um 15:02 Uhr
Hey Bastla,

ok - das Makro läuft nun durch wenn ich "Tabelle3" durch 3 ohne Sting ersetze. Jedoch kopiert er 4:4 nicht in die Gesamtdatei :O Er springt nun fleißig durch die ganzen *.xls und wählt auch die richtigen Zeilen in der Gesamtdatei, jedoch bleiben die Spalten leer :/

Sorry wenn ich mich so doof anstelle, aber ich glaube ich habe das (noch) Makro nicht zerstört :P


Vielen Dank!

//edit:
Hallo noch einmal,

sorry natürlich war es mein Fehler :D
Das Makro lag die ganze Zeit in "DieseArbeitsmappe" wenn ich es von dem Table "Data" aus starte funktioniert es :P

Ich teste jetzt noch einmal ein wenig rum, aber eigentlich sollte es nun laufen.

Bastla, noch einmal vielen Dank!
Bitte warten ..
Mitglied: trdshimo
18.01.2013, aktualisiert um 15:30 Uhr
Hallo Bastla,

nun habe ich doch noch einmal eine Frage. Anfangs dachte ich es müsste reichen einfach die komplette Zeile zu kopieren (was nun auch wunderbar funktioniert), aber da ich in den auszulesenen Tabellen nicht alle Spalten nutze und in der Gesamtdatei noch einige Spalten vorschieben wollte, habe ich nun von "2:2" auf "B4:AA4" umgemünzt.

Wie bekomme ich es nun hin, das ich doch wieder eine "iSpalte" mit in das Makro bauen kann, sprich ich entscheiden kann, ab welcher Spalte und Zeile er mir die Werte der Tabellen "B4:AA4" in die Gesamt-Tabelle schreibt?

Noch eine kleine Frage, wie kann ich es vermeiden das dass Makro abbricht wenn mal kein "Tabelle3" Blatt existiert, gibt es hier eine Art "Bei Fehler überspringen" (was genial wäre, wäre natürlich eine msgBox die die Fehlerhaften Dateien am Ende anzeigt, aber das wäre purer Luxus)

Könnte das Makro auch so erweitet werden, das er die gleiche Syntax auf 2 Dateipfade anwendet, die ergebnisse dann dementsprechend einfach untereinander wegschreibt? Sprich erst Ergebnisse aus Dateipfad 1, beispiel Zeile 1 bis 50 und dann ab Zeile 51 die Ergebnisse aus Dateipfad 2?

So sieht mein Makro aktuell aus

01.
Sub GetData() 
02.
 
03.
'Data Sheet ab Zeile 2 löschen 
04.
Worksheets("Data").Activate 
05.
Range("2:65536").Clear 
06.
 
07.
Const sDateiPfad As String = "C:\test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende 
08.
Const sTabQuelle As String = "Tabelle3" 'Tabellenname in den Quelldateien 
09.
Const sTabZiel As String = "Data" 'Tabellenname in der Zieldatei 
10.
sZeile = "B4:AA4" 'auszulesender Bereich 
11.
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen 
12.
 
13.
Set oMe = ThisWorkbook.Sheets(sTabZiel) 
14.
 
15.
Set oFS = CreateObject("Scripting.FileSystemObject") 
16.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files 
17.
    sWbName = oDatei.Name 
18.
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then 
19.
        Workbooks.Open (sDateiPfad & sWbName) 'Quelldatei öffnen 
20.
        Sheets(sTabQuelle).Range(sZeile).Copy 'Quellbereich (Zeile 2) kopieren und ... 
21.
        oMe.Rows(iZeile).PasteSpecial xlPasteValues '... in Zieldatei nur Werte einfügen 
22.
        oMe.Cells(iZeile, 1).Copy 'Dummy, um Frage nach "großer Menge von Informationen in der Zwischenablage" zu vermeiden 
23.
        oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, "A"), Address:=sDateiPfad & sWbName, TextToDisplay:=sDateiPfad & sWbName 'Hyperlink 
24.
        Workbooks(sWbName).Saved = True 
25.
        Workbooks(sWbName).Close 
26.
        iZeile = iZeile + 1 'Zeilennummer füür Zieldatei erhöhen 
27.
    End If 
28.
Next 
29.
Application.CutCopyMode = False 
30.
 
31.
End Sub

Noch einmal VIelen Dank!!!
Bitte warten ..
Mitglied: bastla
18.01.2013, aktualisiert um 16:14 Uhr
Hallo trdshimo!

Dann etwa so:
01.
Sub GetData() 
02.
aPfade = Array("C:\Test", "D:\Versuch", "E:\Probe") 'Pfade für zu durchsuchende Excel-Dateien; ohne Backslash am Ende 
03.
Const sTabQuelle As String = "Tabelle3" 'Tabellenname in den Quelldateien 
04.
Const sTabZiel As String = "Data" 'Tabellenname in der Zieldatei 
05.
sZeile = "B4:AA4" 'auszulesender Bereich 
06.
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen 
07.
iSpalte = 3 'ab dieser Spalte Daten in Zieltabelle einfügen 
08.
 
09.
Set oMe = ThisWorkbook.Sheets(sTabZiel) 'Sammeltabelle als Objekt zwischenspeichern 
10.
 
11.
oMe.Range("2:65536").Clear 'Data Sheet ab Zeile 2 löschen 
12.
 
13.
Set oFS = CreateObject("Scripting.FileSystemObject") 
14.
For Each sDateiPfad In aPfade 'alle Pfade durchgehen 
15.
    For Each oDatei In oFS.GetFolder(sDateiPfad).Files 'alle Dateien des aktuellen Pfads durchgehen 
16.
        sWbName = oDatei.Name 
17.
        If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then 
18.
            Workbooks.Open (oDatei.Path) 'Quelldatei öffnen 
19.
            On Error Resume Next 
20.
            Sheets(sTabQuelle).Range(sZeile).Copy 'Quellbereich kopieren und ... 
21.
            If Err.Number = 0 Then '... falls kein Fehler aufgetreten ist ... 
22.
                On Error GoTo 0 
23.
                oMe.Cells(iZeile, iSpalte).PasteSpecial xlPasteValues '... in Zieldatei nur Werte einfügen 
24.
                oMe.Cells(iZeile, 1).Copy 'Dummy, um Frage nach "großer Menge von Informationen in der Zwischenablage" zu vermeiden 
25.
                oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, "A"), Address:=oDatei.Path, TextToDisplay:=oDatei.Path 'Hyperlink 
26.
                iZeile = iZeile + 1 'Zeilennummer für Zieldatei erhöhen 
27.
            Else 'Bei Fehler: 
28.
                On Error GoTo 0 
29.
                sErrors = sErrors & vbNewLine & oDatei.Path 'Dateipfad der Liste hinzufügen 
30.
            End If 
31.
            Workbooks(sWbName).Saved = True 
32.
            Workbooks(sWbName).Close 
33.
        End If 
34.
    Next 'oDatei 
35.
Next 'sDateiPfad 
36.
Application.CutCopyMode = False 'Kopiermodus beenden 
37.
If sErrors <> "" Then MsgBox sErrors, vbCritical, "Fehlerhafte Dateien" 'Falls vorhanden, fehlerhafte Dateien anzeigen 
38.
End Sub
Es ist bei der Angabe der Pfade nicht mehr nötig, am Ende einen Backslash zu setzen.

Grüße
bastla
Bitte warten ..
Mitglied: trdshimo
21.01.2013 um 09:27 Uhr
Bastla,

nur ein wort... GENIAL!

Es funktioniert genauso wie ich es brauche! VIELEN VIELEN VIELEN DANK!!!
Bitte warten ..
Mitglied: Paterson
06.12.2016 um 15:54 Uhr
Hallo bastla,

ich bin recht neue Hier und hoffe sehr auf ihre Unterstützung.
ich bekomme jeden tag eine Datei mit mehrere Excel Tabellen
ich muss aus dem Dateien nur einen bestimmten Datenblatt auswerten.
so sehen sie ungefähr.
Block Weight [kg] X Y Z Material Density
SA2101 334514 1 2 3 A 8000kg/m3
SA2101 044514 1 2 3 A 8000kg/m3
SA3101 334514 1 2 3 A 8000kg/m3
SA3101 334514 1 2 3 A 8000kg/m3
SA2101 334514 1 2 3 A 8000kg/m3
SA5101 334514 1 2 3 A 8000kg/m3
SA5101 334514 1 2 3 A 8000kg/m3
als Beispiel

ich möchte alle typen aussuchen und summieren in gruppen in eine anderen Tabelle
und automisch neue typen erkennen und ausführen.

folgendes habe ich geschrieben aber er speichert die Daten nicht in die neue Tabelle.

Application.ScreenUpdating = False
' turns off screen updating
Application.DisplayStatusBar = True
' makes sure that the statusbar is visible
' Application.Wait Now + TimeValue("00:00:02")



'---------------------------------------------------
'Initialisierung der Variablen
'---------------------------------------------------

Dim oMe As Object, sSuchbegriff()
Dim oFS As Object
Dim oDatei As Object

Dim actRow As Long
Dim actGroup As String
Dim sBereich As String
Dim sKennz As String
Dim sWbName As String
Dim bEintrag As Boolean
Dim wsTabelle As Worksheet


Dim rFound As Range
Dim vWert As Variant


Dim actGroupNumber As Integer 'Zeile, in der die erste Zusammenfassung geschrieben wird
Dim iSbMax As Integer
Dim iLK As Integer
Dim i As Integer
Dim iZeile As Integer

Dim totalWeight As Double 'Totales Gewicht; Summation der einzelnen Posten
Dim totalGroupWeight As Double 'Totales aktuelles Gruppengewicht
Dim totaladdedGroupWeight As Double 'Totales Gewicht, Summation der einzelnen Gruppen
'---------------------------------------------------
'Setzen der Variablen
'---------------------------------------------------

Set oMe = ThisWorkbook.Worksheets("Auswertung") 'Zieltabelle (in der gerade geöffneten Datei)
'iZeile = 2 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen
actRow = 5 'Zeile, in der die Iteration beginnt
actGroupNumber = 5

totalWeight = 0
totalGroupWeight = 0
totaladdedGroupWeight = 0

Const sDateiPfad As String = "C:\Users\wis-ikk\Desktop\2016_11_04" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende
sKennz = "HULL WCOG" 'Nur Tabellen, deren Name mit dem Kennzeichen beginnt, verarbeiten

iLK = Len(sKennz) 'Länge des Tabellennamen-Kennzeichens
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
Workbooks.Open (oDatei.Path)
For Each wsTabelle In Workbooks(sWbName).Worksheets()
If StrComp(Left(wsTabelle.Name, iLK), sKennz, vbTextCompare) = 0 Then

bEintrag = False
For i = 0 To iSbMax

actGroup = Worksheets("HULL WCOG").Cells(actRow, 2)


Do While Not Worksheets("HULL WCOG").Cells(actRow, 1) = ""

Application.StatusBar = "Processing Group " & actGroup & " | Processed Items: " & actRow

If (actGroup <> Worksheets("HULL WCOG").Cells(actRow, 2)) Then

'Group Values speichern
Worksheets("HULL WCOG").Cells(actGroupNumber, 14) = actGroup
Worksheets("HULL WCOG").Cells(actGroupNumber, 15) = totalGroupWeight

'neuen Gruppennamen definieren
actGroup = Worksheets("HULL WCOG").Cells(actRow, 2)
actGroupNumber = actGroupNumber + 1

totaladdedGroupWeight = totaladdedGroupWeight + totalGroupWeight

totalGroupWeight = Worksheets("HULL WCOG").Cells(actRow, 5)



Else
Dim tempGroupfromPartName As String
tempGroupfromPartName = Left(Worksheets("HULL WCOG").Cells(actRow, 3), 6)


If Not (tempGroupfromPartName = actGroup) Then
Dim Mldg, Stil, Titel, Antwort
Mldg = "BLOCK MODULE NAME " & actGroup & " mit PART NAME " & tempGroupfromPartName & " nicht konsistent! Fortfahren?" ' Meldung definieren.
Stil = vbYesNo + vbCritical + vbDefaultButton2 ' Schaltflächen definieren.
Titel = "MsgBox-Demonstration" ' Titel definieren.

Antwort = MsgBox(Mldg, Stil, Titel) ' Meldung anzeigen.

If Antwort = vbYes Then ' Benutzer hat "Ja" gewählt.

Else ' Benutzer hat "Nein" gewählt.
Exit Sub
End If



End If

totalGroupWeight = totalGroupWeight + Worksheets("HULL WCOG").Cells(actRow, 5)

End If


totalWeight = totalWeight + Worksheets("HULL WCOG").Cells(actRow, 5)

actRow = actRow + 1

Loop


totaladdedGroupWeight = totaladdedGroupWeight + totalGroupWeight

Worksheets("HULL WCOG").Cells(actGroupNumber, 14) = actGroup
Worksheets("HULL WCOG").Cells(actGroupNumber, 15) = totalGroupWeight



Worksheets("HULL WCOG").Cells(actGroupNumber + 2, 14) = "Total Weight"
Worksheets("HULL WCOG").Cells(actGroupNumber + 2, 15) = totalWeight
Worksheets("HULL WCOG").Cells(actGroupNumber + 3, 14) = "Total Added Group Weight"
Worksheets("HULL WCOG").Cells(actGroupNumber + 3, 15) = totaladdedGroupWeight

Next
If bEintrag Then iZeile = iZeile + 1 'mindestens ein Eintrag erfolgt, daher neue Zeile
End If


Next
Workbooks(sWbName).Saved = True

Workbooks(sWbName).Close

Next
Application.ScreenUpdating = True
' gives control of the statusbar back to the programme

End Sub


was mache ich den falsch ????

Leute bitte Hiiiilfeeeeeeeee!!!!!!!!!!!!!!!!!!!!!!!!
Bitte warten ..
Neuester Wissensbeitrag
Windows 10

Powershell 5 BSOD

(8)

Tipp von agowa338 zum Thema Windows 10 ...

Ähnliche Inhalte
Microsoft Office
gelöst Excel: Mittelwert alle 96 Zeilen berechnen (6)

Frage von sims zum Thema Microsoft Office ...

Batch & Shell
Namen mehrerer Dateien ergänzen per Batchdatei (2)

Frage von adventureman2 zum Thema Batch & Shell ...

Microsoft Office
gelöst Excel-Makro (7)

Frage von yuki13 zum Thema Microsoft Office ...

Heiß diskutierte Inhalte
Microsoft
Ordner mit LW-Buchstaben versehen und benennen (21)

Frage von Xaero1982 zum Thema Microsoft ...

Netzwerkmanagement
gelöst Anregungen, kleiner Betrieb, IT-Umgebung (18)

Frage von Unwichtig zum Thema Netzwerkmanagement ...

Windows Update
Treiberinstallation durch Windows Update läßt sich nicht verhindern (17)

Frage von liquidbase zum Thema Windows Update ...