Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1024to1028
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@ Tino wg. 100 Excellisten durchsuchen

@ Tino wg. 100 Excellisten durchsuchen
20.11.2008 08:20:00
Jessi
Hallo Tino,
Du hast nachträglich auf mein vorheriges Posting folgenden Code gepostet:
Option Explicit

Sub Test()
Dim Fso, Ordner, varDatei
Dim DateiName As String
Dim i As Long
'ab welcher Zeile einfügen
i = 2
Set Fso = CreateObject("Scripting.FileSystemObject")
'hier Pfad angeben
Set Ordner = Fso.getfolder("J:\1 Forum")
'Schleife über alle Dateien im Ordner
For Each varDatei In Ordner.Files
If LCase(varDatei) Like "*.xlsm" Then
'Dateiname ausfiltern
DateiName = LCase(Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")))
If IsNumeric(Replace(DateiName, ".xlsm", "")) Then
'Name der Datei schreiben ohne Extention
Cells(i, "A") = Replace(DateiName, ".xlsm", "")
'String Formel erstellen, Achtung hier ist der Tabellenname zu beachten, hier Tabelle1
DateiName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range(" _
U4").Address(ReferenceStyle:=xlR1C1))
'schreibe Wert in Zelle
Cells(i, "B") = ExecuteExcel4Macro(DateiName)
'Zähler hochzählen für nächste Zeile
i = i + 1
End If
End If
Next varDatei
End Sub


Diesen habe ich auch eingebunden, der Code läuft ohne "Bezugsfehler". Danke dafür.
Jetzt hätte ich eine Frage und es wäre absolut super, wenn ich das hinbekommen würde:
Der in Zelle U4 stehende €-Wert setzt sich aus verschiedenen Gewerken zusammen.
d.h. z.B.
U4 = 100.000 €
dabei steht in Spalte E ab Zeile 6 ggf. ein String z.b. "Textmuster" dieses Textmuster enthält eine zugehörigen € Wert in Spalte U ab Zeile 6. Ist es möglich diese mitzuübetragen? so, dass ich auf meinem neuen "Auswertungsbogen" sehe wie sich das Total (U4) zusammensetzt?
Wäre super, wenn es da eine Möglichkeit geben würde...
LG
Jessi

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: @ Tino wg. 100 Excellisten durchsuchen
20.11.2008 08:52:00
Tino
Hallo,
ganz verstanden habe ich Deine Frage nicht!
Verstanden habe ich, dass Du die Werte aus E6 und U6 auch brauchst.
Das Wörtchen ab in Deiner Frage verwirrt mich etwas,
müssen die Einträge gesucht werden, müsste man jede Datei öffnen und entsprechend verarbeiten.
Sub Test()
Dim Fso, Ordner, varDatei
Dim DateiName As String
Dim i As Long
'ab welcher Zeile einfügen 
i = 2
Set Fso = CreateObject("Scripting.FileSystemObject")
'hier Pfad angeben 
Set Ordner = Fso.getfolder("J:\1 Forum")
'Schleife über alle Dateien im Ordner 
For Each varDatei In Ordner.Files
 If LCase(varDatei) Like "*.xlsm" Then
    
    'Dateiname ausfiltern 
   DateiName = LCase(Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")))
    If IsNumeric(Replace(DateiName, ".xlsm", "")) Then
      'Name der Datei schreiben ohne Extention 
      Cells(i, "A") = Replace(DateiName, ".xlsm", "")
      
      'Wert aus U4 in Spalte B********************* 
      DateiName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range("U4").Address(ReferenceStyle:=xlR1C1))
      Cells(i, "B") = ExecuteExcel4Macro(DateiName)
      
      'Wert aus E6 in Spalte C********************* 
      DateiName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range("E6").Address(ReferenceStyle:=xlR1C1))
      Cells(i, "C") = ExecuteExcel4Macro(DateiName)
      
      'Wert aus U6 in Spalte D********************* 
      DateiName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range("U6").Address(ReferenceStyle:=xlR1C1))
      Cells(i, "D") = ExecuteExcel4Macro(DateiName)
      
      i = i + 1
    End If
 
 End If
Next varDatei

End Sub


Gruß Tino

www.VBA-Excel.de


Anzeige
AW: @ Tino wg. 100 Excellisten durchsuchen
20.11.2008 09:21:02
Jessi
sorry, habe meinen Text nochmal durchgelesen, liegt wohl an meiner starken Erkältung ;-).
Also ich habe jetzt mal eine Datei hochgeladen.
In dieser hochgeladenen Datei wird nach U4 (Gesamtergebnis) gesucht und dieser Wert wird in eine neue Liste übertragen (Spalte A, B). (= CODE VON DIR)
Dieser Gesamtpreis (U4) setzt sich allerdings aus verschiedenen Einzelpositionen zusammen, die wiederum in Gewerken (Test, Tester, Testmuster z.B.) zusammengefasst werden können. Die Teilergebnisse der Gewerke ergeben das Gesamtergebnis (U4).
Ist es möglich die Bestandteile aufgrund der in Spalte "E" angegebenen "Gewerkebezeichnung" die Liste zu durchsuchen?
In der Beispieldatei ist das Gesamtergebnis z.B. 15
dieses setzt sich zusammen aus folgenden Gewerken
Testmuster 4 (aus Bestandteil 1+3)
Test 2 (aus Bestandteil 2)
Tester 9 (aus Bestandteil 4+5)
Eben genau diese Ergebnisse der Gewerke sollte mit übetragen werden mit dem Code (ab Spalte C)
Weißt Du was ich meine ;-) Mein Kopf mag heute nicht so recht...
LG Jessi
Anzeige
noch ein fehler, Korrektur
20.11.2008 09:14:23
Tino
Hallo,
da war noch ein Fehler drin, sorry
Option Explicit

Sub Test()
Dim Fso, Ordner, varDatei
Dim DateiName As String, tempName As String
Dim i As Long
'ab welcher Zeile einfügen 
i = 2
Set Fso = CreateObject("Scripting.FileSystemObject")
'hier Pfad angeben 
Set Ordner = Fso.getfolder("J:\1 Forum")
'Schleife über alle Dateien im Ordner 
For Each varDatei In Ordner.Files
 If LCase(varDatei) Like "*.xlsm" Then
    
    'Dateiname ausfiltern 
   DateiName = LCase(Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")))
    If IsNumeric(Replace(DateiName, ".xlsm", "")) Then
      'Name der Datei schreiben ohne Extention 
      Cells(i, "A") = Replace(DateiName, ".xlsm", "")
      
      'Wert aus U4 in Spalte B********************* 
      tempName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range("U4").Address(, , xlR1C1))
      Cells(i, "B") = ExecuteExcel4Macro(tempName)
      
      'Wert aus E6 in Spalte C********************* 
      tempName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range("E6").Address(, , xlR1C1))
      Cells(i, "C") = ExecuteExcel4Macro(tempName)
      
      'Wert aus U6 in Spalte D********************* 
      tempName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!" & Range("U6").Address(ReferenceStyle:=xlR1C1))
      Cells(i, "D") = ExecuteExcel4Macro(tempName)
      
      i = i + 1
    End If
 
 End If
Next varDatei

End Sub


Gruß Tino

www.VBA-Excel.de


Anzeige
AW: noch ein fehler, Korrektur
20.11.2008 09:25:00
Jessi
Hallo Tino, DANKE habe gar nicht gesehen, dass da ein Code drin war. Ich denke das diese Lösung passen würde, wenn ich in den jeweiligen Liste eine Zelle vorsehe, die mir die einzelnen Komponenten als Gewerkergebnis zusammenfasst, d.h. es müsste keine Schleife drüberlaufen und sich zuerst die Gewerkebestandteile zusammensuchen. Denke mal, dass das funktionieren würde. Wenn das andere zuviel Aufwand wäre, würde ich das so mal probieren...
trotzdem schonmal DANKE!!!!
LG
Jessi
AW: noch ein fehler, Korrektur
20.11.2008 09:28:30
Tino
Hallo,
könnte ich Deine Datei sehen die Du hochgeladen hast, würde ich mir dass mal anschauen,
kann diese aber in Deinem Beitrag nicht sehen.
Gruß Tino
Anzeige
AW: Upload
20.11.2008 10:07:50
Tino
Hallo,
ich schaue es mir mal an und melde mich wieder, muss aber kurtz weck..
Gruß Tino
AW: Upload
20.11.2008 10:09:00
Jessi
absolut kein Problem Tino, bin wirklich sehr dankbar, dass Du Dir mein Anliegen anschauen wirst ;-).
LG
Jessi
AW: Upload
20.11.2008 13:27:00
Tino
Hallo,
da es mich jetzt selbst mal interessiert hat ob ich die Daten zusammenbekomme ohne die Datei zu öffnen, habe ich nun folgenden Code zusammengestellt.
Voraussetzung, die Tabellen sind alle gleich aufgebaut!
Option Explicit

Sub Test()
Dim Fso, Ordner, varDatei
Dim DateiName As String, tempName As String, varWert, tempStrDatei As String
Dim i As Long, A As Long, lngCol As Long, Bereich As Range
Dim lLetzte As Long
'ab welcher Zeile einfügen 
i = 2
Set Fso = CreateObject("Scripting.FileSystemObject")
'hier Pfad angeben 
Set Ordner = Fso.getfolder("J:\1 Forum\Neuer Ordner")
'Schleife über alle Dateien im Ordner 
Cells.Clear
Range("A1") = "Dateiname": Range("B1") = "Ergebnis U4"
Range("A1:B1").Font.Bold = True

With Application
 .ScreenUpdating = False
 
For Each varDatei In Ordner.Files
    If LCase(varDatei) Like "*.xls" Then
    
        'Dateiname ausfiltern 
        DateiName = LCase(Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")))
  'Statusbar Anzeige aktualisieren 
  .StatusBar = "lese Datei: " & DateiName & ", bitte warten..."
        If IsNumeric(Replace(DateiName, ".xls", "")) Then
            'Name der Datei schreiben ohne Extention 
            Cells(i, "A") = Replace(DateiName, ".xls", "")
            'Wert aus U4 in Spalte B********************* 
            tempStrDatei = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]Tabelle1'!")
            tempName = tempStrDatei & Range("U4").Address(, , xlR1C1)
            Cells(i, "B") = ExecuteExcel4Macro(tempName)
            'Bereich für Überschrift********************* 
            Set Bereich = Range(Cells(i - 1, "c"), Cells(i - 1, Columns.Count))
            'Überschrift Fett********************* 
            Bereich.Font.Bold = True
                tempName = _
                    "=LOOKUP(2,1/(" & tempStrDatei & "R7C5:R65000C5<>""""),ROW(" & tempStrDatei & "R7C5:R65000C5))"
             'String für Formel letzte Zeile bestimmen 
             Cells(1, Columns.Count).Formula = tempName
             'Letzte Zeile Bestimmen***************************************** 
             lLetzte = Cells(1, Columns.Count): Cells(1, Columns.Count).Clear
            For A = 7 To lLetzte
                tempName = tempStrDatei & Range("E" & A).Address(, , xlR1C1)
                varWert = ExecuteExcel4Macro(tempName)
                If Application.WorksheetFunction.CountIf(Bereich, varWert) = 0 And varWert <> 0 And varWert <> "" Then
                    lngCol = lngCol + 1
                    Bereich(lngCol) = varWert
                    
                    'String SUMMENPRODUKT Einzelwerte********************* 
                    tempName = _
                        "=SUMPRODUCT((" & tempStrDatei & _
                        Range("E7:E" & lLetzte).Address(, , xlR1C1) & "=" & Bereich(lngCol).Address(, , xlR1C1) & _
                        ")*(" & tempStrDatei & _
                        Range("U7:U" & lLetzte).Address(, , xlR1C1) & "))"
                    
                    'Ergebnis in Zelle schreiben********************* 
                    Bereich(lngCol).Offset(1, 0) = [tempName]
                    Bereich(lngCol).Offset(1, 0).Value = Bereich(lngCol).Offset(1, 0).Value
                End If
            Next A
            
            lngCol = 0
            i = i + 3
        End If
    
    End If
Next varDatei

 .StatusBar = False
 .ScreenUpdating = True
End With

End Sub


Makro in einer leeren Tabelle ausgeführt, sollte dieses Ergebnis bringen.

 ABCDE
1DateinameErgebnis U4TestmusterTestTester
25697515429
3     
4  TestmusterTestTester
55697615429
6     
7  TestmusterTestTester
85697715429

Gruß Tino

www.VBA-Excel.de


Anzeige
AW: Upload
21.11.2008 08:12:00
Jessi
Hallo Tino,
Danke für Dein Post. Ich habe gestern parallel zu Deinem letzten Posting den alten Code mal eingearbeitet mit leichten Änderungen hinsichtlich des Layouts des Excelsheets bzw. Start der Zeilenbefüllung und Anordnung der Spaltenbefüllung. Es ist z.B. mittels SVerweis (s. DataPool Sheet) nun ein Namen für die einzelnen Dateien bzw. ausgelesenen Nummern definiert, so dass ich auf dem Sheet auch sehe von welchem Element ich gerade rede:
01 = Musterteilleistung 1
02 = Musterteilleistung 2
(...)
Die Datei mit dem alten Code, aber für mich benötigtem Layout ist hier:
https://www.herber.de/bbs/user/57010.xls
Leider habe ich den Code nicht dementsprechend anpassen können, so dass ich als Ergebnis hinter dem Total € (= U4 Ergebnis) einfach nur die Gewerke-Teilkosten habe.
Vllt ist es nur ein "Handgriff" für Dich...
Wenn nicht lasse ich mir was anderes einfallen :-)
Danach werde ich Dich auch sicherlich NICHT mehr nerven...
LG + Danke für Deine GROßE HILFE!
Jessi
Anzeige
AW: Upload
21.11.2008 10:45:00
Tino
Hallo,
versuche es mal mit diesem Code.
Die Beschriftung in den 100 Dateien muss aber gegeben sein
Teilkosten-Gewerk 1, Teilkosten-Gewerk 2, Teilkosten-Gewerk 3
in dem Beispiel das ich von Dir habe, ist dies nicht gegeben. (da stehen andere)
Der Dateiname in Spalte A wird überschrieben, möchtest Du dies nicht,
müssen wir eine andere Schleife einbauen.
Sub Schaltfläche1_KlickenSieAuf()

Dim Fso, Ordner, varDatei
Dim DateiName As String, tempStrDatei As String, tempName As String
Dim i As Long
Dim Bereich As Range

Set Bereich = Range("E4:G4")
'ab welcher Zeile einfügen 
i = 5
lngCol = 1 'für Teilergebnisse 

Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = Fso.getfolder("C:\Cost Estimation Input\CostEstimator\Template_DINList-Element")
'Schleife über alle Dateien im Ordner 
For Each varDatei In Ordner.Files
 If LCase(varDatei) Like "*.xlsm" Then
    
    'Dateiname ausfiltern 
   DateiName = LCase(Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")))
   tempStrDatei = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]1_Bau+Planung(Detail)'!")

    If IsNumeric(Replace(DateiName, ".xlsm", "")) Then
      'Name der Datei schreiben ohne Extention 
      Cells(i, "A") = Replace(DateiName, ".xlsm", "") 'Dateiname ******************* 
      
      'String Formel erstellen, Achtung hier ist der Tabellenname zu beachten, hier Tabelle1 
      DateiName = tempStrDatei & Range("U4").Address(ReferenceStyle:=xlR1C1)
      'schreibe Wert in Zelle 
      Cells(i, "D") = ExecuteExcel4Macro(DateiName)
      'Zähler hochzählen für nächste Zeile 
     
            'Schleife Teilergebnisse 
            For a = 1 To 3
                  
                    'String SUMMENPRODUKT Einzelwerte********************* 
                    tempName = _
                        "=SUMPRODUCT((" & tempStrDatei & _
                        Range("E7:E65000").Address(, , xlR1C1) & "=" & Bereich(a).Address(, , xlR1C1) & _
                        ")*(" & tempStrDatei & Range("U7:U65000").Address(, , xlR1C1) & "))"
                    
                    'Teilergebnis in Zelle schreiben als Formel********************* 
                    Bereich(a).Offset(lngCol, 0) = [tempName]
                    Bereich(a).Offset(lngCol, 0).Value = Bereich(a).Offset(lngCol, 0).Value

            Next a
            
            lngCol = lngCol + 1
            i = i + 1

 
    End If 'Nummeric 
 End If
Next varDatei

ActiveSheet.Cells(1, 4).Value = Now
ActiveSheet.Cells(2, 4).Value = Application.UserName

End Sub


GRuß Tino

Anzeige
DANKE!
21.11.2008 13:41:34
Jessi
Hallo Tino,
ich weiß gar nicht wie ich Dir danken kann. Es läuft super innerhalb der 3 Gewerke. Bzgl. der Sache mit Überschriften definieren oder Überschriften aus den 100 Dateien ziehen...Ich definiere die Überschriften in der Übersichtstabelle, so dass der von Dir gepostete Code passt. Einzigste Frage (da ich mehr als 3 Gewerke habe) wie kann ich mehrere Spalten füllen? Was müsste ich dazu ändern? Ich habe z.B. 13 Gewerke derzeit.
Das ändern der Schleifenanzahl von 3 auf 13 passt nicht. Muss da drunter noch was geändert werden?
LG + D A N K E ! ! ! ! !
Jessi
Anzeige
AW: Bitte!
21.11.2008 14:22:00
Tino
Hallo,
na super, schön dass es funktioniert.
Damit es für Dich etwas einfacher für die Gewerke geht, habe ich etwas im Code umgestellt.
Oben in der Zeile Set Bereich = Range("E4:G4"),
kannst Du den Bereich für die Gewerke anpassen,
die Schleife dazu berechnet sich daraus automatisch und Du musst Dir keine Gedanken darum machen.
Damit der Ablauf etwas schneller geht, habe ich noch was eingebaut.
Sub Schaltfläche1_KlickenSieAuf()

Dim Fso, Ordner, varDatei
Dim DateiName As String, tempStrDatei As String, tempName As String
Dim i As Long
Dim Bereich As Range

Set Bereich = Range("E4:G4") 'hier Bereich Gewerke 
'ab welcher Zeile einfügen 
i = 5
lngCol = 1 'für Teilergebnisse 

Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = Fso.getfolder("C:\Cost Estimation Input\CostEstimator\Template_DINList-Element")
'Schleife über alle Dateien im Ordner 
With Application
 .ScreenUpdating = False

For Each varDatei In Ordner.Files
 If LCase(varDatei) Like "*.xlsm" Then
 
    'Dateiname ausfiltern 
   DateiName = LCase(Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")))
 .StatusBar = "Lese Datei: " & DateiName
   tempStrDatei = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]1_Bau+Planung(Detail)'!")

    If IsNumeric(Replace(DateiName, ".xlsm", "")) Then
      'Name der Datei schreiben ohne Extention 
      Cells(i, "A") = Replace(DateiName, ".xlsm", "") 'Dateiname ******************* 
      
      'String Formel erstellen, Achtung hier ist der Tabellenname zu beachten, hier Tabelle1 
      DateiName = tempStrDatei & Range("U4").Address(ReferenceStyle:=xlR1C1)
      'schreibe Wert in Zelle 
      Cells(i, "D") = ExecuteExcel4Macro(DateiName)
      'Zähler hochzählen für nächste Zeile 
     
            'Schleife Teilergebnisse 
            For a = 1 To Bereich.Cells.Count
                  
                    'String SUMMENPRODUKT Einzelwerte********************* 
                    tempName = _
                        "=SUMPRODUCT((" & tempStrDatei & _
                        Range("E7:E65000").Address(, , xlR1C1) & "=" & Bereich(a).Address(, , xlR1C1) & _
                        ")*(" & tempStrDatei & Range("U7:U65000").Address(, , xlR1C1) & "))"
                    
                    'Teilergebnis in Zelle schreiben als Formel********************* 
                    Bereich(a).Offset(lngCol, 0) = [tempName]
                    Bereich(a).Offset(lngCol, 0).Value = Bereich(a).Offset(lngCol, 0).Value

            Next a
            
            lngCol = lngCol + 1
            i = i + 1

 
    End If 'Nummeric 
 End If
Next varDatei
.StatusBar = False
.ScreenUpdating = True
End With 'Application 

ActiveSheet.Cells(1, 4).Value = Now
ActiveSheet.Cells(2, 4).Value = Application.UserName

End Sub


Gruß Tino

www.VBA-Excel.de


Anzeige
AW: Bitte!
21.11.2008 15:00:00
Jessi
...heute abend trinke ich ein Glas Wein auf Deine Arbeit! Absolute spitze! FUNKTIONIERT EINWANDFREI! DANKE TINO!!!!!!!
AW: Bitte!
21.11.2008 15:03:00
Tino
Hallo Jessi,
danke für die positive Rückmeldung!
PS: ich trinke gern Rotwein ;-)
Gruß Tino

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige