Excel: Verzeichnis durchsuchen und aus Dateien bestimmte Felder übernehmen

Dieses Thema Excel: Verzeichnis durchsuchen und aus Dateien bestimmte Felder übernehmen im Forum "Microsoft Office Suite" wurde erstellt von falcon35, 31. Aug. 2005.

Thema: Excel: Verzeichnis durchsuchen und aus Dateien bestimmte Felder übernehmen Hallo Zusammen, ich möchte eine Exeldatei erstellen die in bestimmten Verzeichnissen nach bestimmten Dateien (z.B....

  1. Hallo Zusammen,

    ich möchte eine Exeldatei erstellen die in bestimmten Verzeichnissen nach
    bestimmten Dateien (z.B. Review*.xls) sucht und hier bestimmte Zellen übernimmt.

    Es muss die möglichkeit bestehen die Suche mehrmals durchlaufen zu lassen.

    Such Verzeichnis und Dateinamen:
    C:\Review\Review*\*\Review*.xls

    Die Übernommenen Zellen aus den Dateien:
    Datenblatt:
    H2
    D5
    B3
    D6
    E10
    G8
    B29:H29

    Reviewprotokoll:
    Hier wird es kompliziert:
    In der Spalte F stehen Bewertungskriterien (z.B.: K,B,F,P,O,I,...)
    In der Spalte G sind die Verantwortlichen
    In der Spalte H ist der gewünschte Erledigungsdatum
    In der Spalte I ist dann der Ist-Erledigungstermin

    Ich hätte jetzt gerne die offenen, also alle Felder der Spalte I gezählt in Abhängigkeiten der Bewertungskriterien und Verantwortlichen und dann Ausgegeben.

    Die Ausgabe DAtei könnte So aussehen:

    [table] [tr] [td]  Verzeichnis [/td][td] Dateiname[/td] [td] Inhalt E10 [/td]  [td] Inhalt G8 [/td]   [td]Inhalt D5 [/td] [td] Inhalt H2 [/td]  [td]Inhalt B3 [/td][td]Inhalt D6 [/td] [td]Inhalte B29:H29[/td]  [td]Verantwortlich[/td]  [td]Bewertungskriterien K[/td] [td]Bewertungskriterien B[/td]  [td]Bewertungskriterien F[/td]  [td]Bewertungskriterien P[/td]  [td]Bewertungskriterien O[/td] [td]Bewertungskriterien I[/td]           
    [/tr]  [/table]

    Ich hoffe es ist klar was ich meine.

    Grüße
    falcon35
     
  2. Hallo falcon35,

    noch ein paar Fragen zu dem Thread:

    Wenn ich das richtig verstanden habe, haben die Dateien Review*.xls 2 Blätter:
    - eines namens->Datenblatt'
    - und eines namens Reviewprotokoll

    pro gefundener Datei sollen in einer Zeile protokolliert werden:
    - Pfad, Datei
    - 13 Werte aus->Datenblatt'
    - pro Verantwortlichem Anz der offenen Bewertungskriterien ( 6 Stück)

    Sollen pro Datei bei mehreren Verantwortlichen die - 13 Werte aus->Datenblatt'  in den Zeilen wiederholt werden ?
    (-> Anzahl Verantwortliche pro Datei = Anzahl Ergebniszeilen)

    Nach welchem Kriterium muß Reviewprotokoll untersucht werden, um die relevanten Zeilen zu finden.
    ( ab welcher Zeile muß man starten,
    Welche Spalte hat immer Inhalte ? (um letzte Zeile zu finden)

    Gruß Matjes :)
     
  3. Hallo Matjes,

    in dem WS: Reviewprotokoll werden Reviewergebnisse eingetragen.
    Es können pro Zeile ein Verantwortlicher Zugewiesen werden, d.h. es sind dann meist mehrere Verantwortliche die irgendetwas zu erledigen haben.

    Sollen pro Datei bei mehreren Verantwortlichen die - 13 Werte aus->Datenblatt' in den Zeilen wiederholt werden ?
    (-> Anzahl Verantwortliche pro Datei = Anzahl Ergebniszeilen)

    -> Die Werte müssen nicht wiederholt werden, es langt wenn es einmal generiert wird.

    Die Anzahl der Zeilen kann ich leider nicht schätzen. Spalte E kann aber dazu benutzt werden um festzustellen wo die letzte Zeile ist.

    Startzeile ist 5.

    Grüße
    falcon35
     
  4. Hallo Zusammen,

    kann mir denn hier keiner helfen?

    HHHHHiiiiiiiiiiiiiiiillllllllllllllllllllllllllllfffffffffffffffffffffffffeeeeeeeeee!! :'(


    Grüße
    falcon30
     
  5. Hi falcon30,

    hast du schon mal in deine mail geschaut   :(  (4.9.2005 gesendet   :D )

    Gruß Matjes  ;)
     
  6. Hallo Matjes,

    ich habe die Datei leider nicht bekommen, kannste sie bitte nochmals auf meine gmx-Adresse schicken?

    Wäre toll.

    Danke!!

    Grüße
    falcon30
     
  7. Hallo falcon30,

    ist an beide Adressen unterwegs.

    Gruß Matjes :)
     
  8. Hallo Matjes,

    dem Esel ist zu wohl - er will aufs Eis.

    Kannst du mir deine Lösung auch mal schicken? Ich will wieder ein paar schlaflose Nächte.
    Das Dim habe ich mittlerweile ganz vorsichtig da und dort eingebaut. Wirklich eine tolle Sache. :) Zum Glück gibt's Copy & Paste.

    Das wäre ein guter Titel für eine SAT1-Vorabens-Serie: Copy & Paste - Aufruhr im Rotlichtmilieu.
     
  9. Hallo klexy,

    zum mitlesen, ausprobieren und studieren  ;D

    Die Spezifikeation hat sich etwas geändert:

    a) Mit eine Auswahl-Dialog wird der Suchpfad bestimmt.
    b) die zu suchenden Dateien habne das Muster->Review*.xls'
    c) Es wrid der suchpfad und seine Unterverzeichnisse  nach diesem Dateimuster durchsucht

    Das ist der augenblickliche Stand.

    Das ganze ist in 3 Module gegliedert. Das Makro heißt ReviewStatistikSammler.

    Gruß Matjes :)

    Modul1:
    Code:
    Option Explicit
    
    '#### A N P A S S E N ######################################
    'Muster zur Review-Datei-Suche
    Const c_Ziel_Speicherpfad = C:\Test\Review\Auswertung
    Const c_DATEIMUSTER_REVIEWS = Review*.xls
    
    
    Const c_Ziel_Dateiname = AuswRev_
    Const c_Ziel_BltName = AuswRev_
    '#### A N P A S S E N ######################################
    
    Const c_BewKrit_K = 1
    Const c_BewKrit_B = 2
    Const c_BewKrit_F = 3
    Const c_BewKrit_P = 4
    Const c_BewKrit_O = 5
    Const c_BewKrit_I = 6
    Const c_BewKrit_andere = 7
    
    Type myReviewAusw_structure
      s_Verantwortlicher              As String
      BewKrit(1 To c_BewKrit_andere)  As Long
    End Type
    
    'Blattbeschreibung Ziel
    Const c_RevZ_Ueberschrift = 1
    Const c_RevZ_ERSTEWERTEZEILE = c_RevZ_Ueberschrift + 1
    Const c_RevSP_Verz = 1:         Const c_RevSP_Verz_TXT = Verzeichnis
    Const c_RevSP_Datei = 2:        Const c_RevSP_Datei_TXT = Dateiname
    Const c_RevSP_E10 = 3:          Const c_RevSP_E10_TXT = E10
    Const c_RevSP_G8 = 4:           Const c_RevSP_G8_TXT = G8
    Const c_RevSP_D5 = 5:           Const c_RevSP_D5_TXT = D5
    Const c_RevSP_H2 = 6:           Const c_RevSP_H2_TXT = H2
    Const c_RevSP_B3 = 7:           Const c_RevSP_B3_TXT = B3
    Const c_RevSP_D6 = 8:           Const c_RevSP_D6_TXT = D6
    Const c_RevSP_B29 = 9:          Const c_RevSP_B29_TXT = B29
    Const c_RevSP_C29 = 10:         Const c_RevSP_C29_TXT = C29
    Const c_RevSP_D29 = 11:         Const c_RevSP_D29_TXT = D29
    Const c_RevSP_E29 = 12:         Const c_RevSP_E29_TXT = E29
    Const c_RevSP_F29 = 13:         Const c_RevSP_F29_TXT = F29
    Const c_RevSP_G29 = 14:         Const c_RevSP_G29_TXT = G29
    Const c_RevSP_H29 = 15:         Const c_RevSP_H29_TXT = H29
    Const c_RevSP_Verantw = 16:     Const c_RevSP_Verantw_TXT = Verantwortlich
    Const c_RevSP_BewKrK = 17:      Const c_RevSP_BewKrK_TXT = Bew.-Kr. K
    Const c_RevSP_BewKrB = 18:      Const c_RevSP_BewKrB_TXT = Bew.-Kr. B
    Const c_RevSP_BewKrF = 19:      Const c_RevSP_BewKrF_TXT = Bew.-Kr. F
    Const c_RevSP_BewKrP = 20:      Const c_RevSP_BewKrP_TXT = Bew.-Kr. P
    Const c_RevSP_BewKrO = 21:      Const c_RevSP_BewKrO_TXT = Bew.-Kr. O
    Const c_RevSP_BewKrI = 22:      Const c_RevSP_BewKrI_TXT = Bew.-Kr. I
    Const c_RevSP_BewKrandere = 23: Const c_RevSP_BewKrandere_TXT = Bew.-Kr. andere
    
    'Beschreibung der Quelldatei
    Const c_QBlt_Daten = Datenblatt
    Const c_QBlt_Review = Reviewprotokoll
    Const c_Q_ERSTEWERTEZEILE = 5
    Const c_QSP_BestZeilen = 5 ->Spalte E zur Bestimmung der letzten Zeile
    Const c_QSP_BewKr = 6       'Spalte F
    Const c_QSP_Verantw = 7     'Spalte G
    Const c_QSP_SollDatum = 8   'Spalte H
    Const c_QSP_IstDatum = 9   ->Spalte H
    '************************************************************************************
    'ich möchte eine Exeldatei erstellen die in bestimmten Verzeichnissen nach
    'bestimmten Dateien (z.B. Review*.xls) sucht und hier bestimmte Zellen übernimmt.
    '
    'Es muss die möglichkeit bestehen die Suche mehrmals durchlaufen zu lassen.
    '
    'Such Verzeichnis und Dateinamen z.B.:
    'Im Verzeichnis C:\Review\Review und allen Unterordnern
    'nach Dateien der Form Review*.xls
    '
    'Die Übernommenen Zellen aus den Dateien:
    'Datenblatt: H2,D5,B3,D6,E10,G8,B29: H29
    '
    'Reviewprotokoll:
    'Hier wird es kompliziert:
    'In der Spalte F stehen Bewertungskriterien (z.B.: K,B,F,P,O,I,...)
    'In der Spalte G sind die Verantwortlichen
    'In der Spalte H ist der gewünschte Erledigungsdatum
    'In der Spalte I ist dann der Ist-Erledigungstermin
    '
    'Ich hätte jetzt gerne die offenen, also alle Felder der Spalte I gezählt in Abhängigkeiten der
    'Bewertungskriterien und Verantwortlichen und dann Ausgegeben.
    '
    'Die Ausgabe DAtei könnte So aussehen:
    '
    'Verzeichnis Dateiname Inhalt E10 
    'Inhalt G8 Inhalt D5 Inhalt H2 Inhalt B3 Inhalt D6 Inhalte B29:H29
    'Verantwortlich Bewertungskriterien K Bewertungskriterien B Bewertungskriterien F
    'Bewertungskriterien P Bewertungskriterien O Bewertungskriterien I
    '
    Sub ReviewStatistikSammler()
    
      Dim wba As Workbook, wsa As Worksheet
      Dim wbq As Workbook, wsqd As Worksheet, wsqr As Worksheet
      Dim wbz As Workbook, wsz As Worksheet
      Dim f_Rev() As myFiles_structure, f_Rev_cnt As Long
      Dim l_zz As Long, l_zq As Long, l_rev As Long
      Dim s_Datum As String, s_ZieldateiName As String
      Dim s_SuchPfad As String
    
     ->Eingabe des Suchpfades
      s_SuchPfad = VerzeichnisAuswahl(Bitte wählen Sie den Suchpfad aus)
      If s_SuchPfad =  Then Exit Sub
    
    
      Application.StatusBar = Dateien suchen
      If Not ReviewFilesSuchen(s_SuchPfad, c_DATEIMUSTER_REVIEWS, f_Rev(), f_Rev_cnt) Then
        MsgBox (Fehler bei Suche der Review-Files)
        GoTo AUFRAEUMEN
      End If
    
     ->aktives Arbeitsblatt merken
      Set wba = ActiveWorkbook: Set wsa = ActiveSheet
      
     ->Bildschirm-Update abschalten
      Application.ScreenUpdating = False
      
     ->Ziel-Mappe anlegen
      Application.StatusBar = Ziel-Datei anlegen
      Call ZielmappeAnlegen(wbz, wsz)
      
      
     ->nächste Wertezeile im Ziel
      l_zz = c_RevZ_ERSTEWERTEZEILE
      
     ->Review-Mappen nacheinander bearbeiten
      For l_rev = 1 To f_Rev_cnt
        On Error Resume Next
       ->Datei Öffnen
        Workbooks.Open FileName:=f_Rev(l_rev).s_VollerPafd
        If Err.Number <> 0 Then
          Err.Clear
          MsgBox (Fehler beim Öffnen von  & vbLf & f_Rev(l_rev).s_VollerPafd)
          GoTo AUFRAEUMEN
        End If
        Set wbq = ActiveWorkbook
        Set wsqd = wbq.Worksheets(c_QBlt_Daten)
        If Err.Number <> 0 Then
          Err.Clear
          MsgBox (Blatt-> & c_QBlt_Daten &-> nicht vorhanden. & vbLf & f_Rev(l_rev).s_VollerPafd)
          GoTo AUFRAEUMEN
        End If
        Set wsqr = wbq.Worksheets(c_QBlt_Review)
        If Err.Number <> 0 Then
          Err.Clear
          MsgBox (Blatt-> & c_QBlt_Review &-> nicht vorhanden. & vbLf & f_Rev(l_rev).s_VollerPafd)
          GoTo AUFRAEUMEN
        End If
        On Error GoTo 0
        
       ->Verarbeiten
        Application.StatusBar = Ergebnis eintragen aus:  & f_Rev(l_rev).s_Dateiname
        Call ReviewVerarbeitenUndWerteInZieldateiEintragen(wsz, l_zz, wsqd, wsqr, wbq)
        
       ->Datei schliessen
        wbq.Close Savechanges:=False
      Next
      
     ->Ziel-Datei Restbearbeitung
      Application.StatusBar = Ende-Bearbeitung der Zieldatei
    
     ->Nach Pfad, Dateiname, Verantwortlichem sortieren
      wsz.UsedRange.Sort _
        Key1:=wsz.Columns(c_RevSP_Verz), Order1:=xlAscending, _
        Key1:=wsz.Columns(c_RevSP_Datei), Order1:=xlAscending, _
        Key1:=wsz.Columns(c_RevSP_Verantw), Order1:=xlAscending, _
        Header:=xlYes
      
     ->Spaltenbreite optimieren und Zoom 75%
      wsz.UsedRange.EntireColumn.AutoFit
      wsz.Activate: ActiveWindow.Zoom = 75
      
     ->Blattnamen vergeben
      s_Datum = Format(Now(), yyyymmdd_hhnnss)
      wsz.Name = c_Ziel_BltName & s_Datum
      
     ->Pagesetup
      With wsz.PageSetup
       .Orientation = xlLandscape   ->xlPortrait->xlLandscape
       .LeftHeader = &Arial,Fett&16 Marquardt
       .CenterHeader = &Arial,Fett&12Auswertung der offenen Reviewpunkte
       .RightHeader = Format(Now(), dd.mm.yyyy)
       .LeftFooter = Ersteller: Sahin Duygun
       .CenterFooter = &P / &N
       .RightFooter = wbz.FullName & ,  & wsz.Name
       .Zoom = False
       .FitToPagesWide = 1
       .FitToPagesTall = 150
      End With
      
     ->Zieldatei speichern
      On Error Resume Next
      s_ZieldateiName = c_Ziel_Speicherpfad & Application.PathSeparator & c_Ziel_Dateiname & s_Datum & .xls
      wbz.SaveAs FileName:=s_ZieldateiName
      If Err.Number <> 0 Then
        Err.Clear
        MsgBox (Zieldatei konnte nicht gespeichert werden. & vbLf & s_ZieldateiName)
        GoTo AUFRAEUMEN
      Else
        On Error GoTo 0
        wbz.Close Savechanges:=False
        Application.ScreenUpdating = True
        MsgBox (Ergebnisfile:  & s_ZieldateiName)
      End If
      
      
    AUFRAEUMEN:
      Application.StatusBar = 
      On Error GoTo 0
      wsa.Activate
      Set wba = Nothing: Set wsa = Nothing
      Set wbq = Nothing: Set wsqd = Nothing: Set wsqr = Nothing
      Set wbz = Nothing: Set wsz = Nothing
    End Sub
    Private Function ReviewVerarbeitenUndWerteInZieldateiEintragen( _
                      wsz As Worksheet, l_zz As Long, wsqd As Worksheet, wsqr As Worksheet, wbq As Workbook)
                      
      Dim f_RevAw() As myReviewAusw_structure, f_RevAw_cnt As Long
      Dim v As Long
      
     ->Rückgabefeld initialisieren
      ReDim f_RevAw(1 To 1): f_RevAw_cnt = 0
    
      Call ReviewBlattAuswerten(wsqr, f_RevAw(), f_RevAw_cnt)
      
      For v = 1 To f_RevAw_cnt
       ->Pfad, Datei eintragen
        wsz.Cells(l_zz, c_RevSP_Verz).Value = wbq.Path
        wsz.Cells(l_zz, c_RevSP_Datei).Value = wbq.Name
       ->Werte aus Datenblatt eintragen
        Call WerteAusDatenblattUebertragen(wsz, l_zz, wsqd)
        
       ->Werte aus Auswertung eintragen
        With f_RevAw(v)
          wsz.Cells(l_zz, c_RevSP_Verantw).Value = .s_Verantwortlicher
          wsz.Cells(l_zz, c_RevSP_BewKrK).Value = .BewKrit(c_BewKrit_K)
          wsz.Cells(l_zz, c_RevSP_BewKrB).Value = .BewKrit(c_BewKrit_B)
          wsz.Cells(l_zz, c_RevSP_BewKrF).Value = .BewKrit(c_BewKrit_F)
          wsz.Cells(l_zz, c_RevSP_BewKrP).Value = .BewKrit(c_BewKrit_P)
          wsz.Cells(l_zz, c_RevSP_BewKrO).Value = .BewKrit(c_BewKrit_O)
          wsz.Cells(l_zz, c_RevSP_BewKrI).Value = .BewKrit(c_BewKrit_I)
          wsz.Cells(l_zz, c_RevSP_BewKrandere).Value = .BewKrit(c_BewKrit_andere)
        End With
        
       ->nächste Zeile
        l_zz = l_zz + 1
      Next
    
    End Function
    Private Function ReviewBlattAuswerten(wsqr As Worksheet, f_RevAw() As myReviewAusw_structure, f_RevAw_cnt As Long)
      
      Dim l_rows As Long, z As Long, v As Long, b_gefunden As Boolean
      Dim s_Verantwortlicher As String, s_BewKriterium As String, l_BewKriterium As Long
      
      
     ->letzte Zeile feststellen
      l_rows = wsqr.Cells(wsqr.Rows.Count, c_QSP_BestZeilen).End(xlUp).Row
      
     ->Alle Zeilen asuwerten
      For z = c_Q_ERSTEWERTEZEILE To l_rows
       ->pruefen, Soll-Datum leer
        If wsqr.Cells(z, c_QSP_IstDatum).Value =  Then
          s_Verantwortlicher = wsqr.Cells(z, c_QSP_Verantw).Value
          s_BewKriterium = UCase(wsqr.Cells(z, c_QSP_BewKr).Value)
          If s_BewKriterium = K Then
            l_BewKriterium = c_BewKrit_K
          ElseIf s_BewKriterium = B Then
            l_BewKriterium = c_BewKrit_B
          ElseIf s_BewKriterium = F Then
            l_BewKriterium = c_BewKrit_F
          ElseIf s_BewKriterium = P Then
            l_BewKriterium = c_BewKrit_P
          ElseIf s_BewKriterium = O Then
            l_BewKriterium = c_BewKrit_O
          ElseIf s_BewKriterium = I Then
            l_BewKriterium = c_BewKrit_I
          Else
            l_BewKriterium = c_BewKrit_andere
          End If
    
         ->Verantwortlichen in Auswertungs-Struktur suchen
          b_gefunden = False
          For v = 1 To f_RevAw_cnt
            If s_Verantwortlicher = f_RevAw(v).s_Verantwortlicher Then
              b_gefunden = True
             ->Kriterium zählen
              f_RevAw(v).BewKrit(l_BewKriterium) = f_RevAw(v).BewKrit(l_BewKriterium) + 1
            End If
          Next
          If Not b_gefunden Then
           ->neuen Verantwortlichen eintragen
            f_RevAw_cnt = f_RevAw_cnt + 1: ReDim Preserve f_RevAw(1 To f_RevAw_cnt)
            f_RevAw(f_RevAw_cnt).s_Verantwortlicher = s_Verantwortlicher
           ->Kriterium zählen
            f_RevAw(v).BewKrit(l_BewKriterium) = 1
          End If
        End If
      Next
    
    End Function
    Private Function WerteAusDatenblattUebertragen(wsz As Worksheet, l_zeile As Long, wsqd As Worksheet)
      
      wsz.Cells(l_zeile, c_RevSP_E10).Value = wsqd.Range(E10).Value
      wsz.Cells(l_zeile, c_RevSP_G8).Value = wsqd.Range(G8).Value
      wsz.Cells(l_zeile, c_RevSP_D5).Value = wsqd.Range(D5).Value
      wsz.Cells(l_zeile, c_RevSP_H2).Value = wsqd.Range(H2).Value
      wsz.Cells(l_zeile, c_RevSP_B3).Value = wsqd.Range(B3).Value
      wsz.Cells(l_zeile, c_RevSP_D6).Value = wsqd.Range(D6).Value
      wsz.Cells(l_zeile, c_RevSP_B29).Value = wsqd.Range(B29).Value
      wsz.Cells(l_zeile, c_RevSP_C29).Value = wsqd.Range(C29).Value
      wsz.Cells(l_zeile, c_RevSP_D29).Value = wsqd.Range(D29).Value
      wsz.Cells(l_zeile, c_RevSP_E29).Value = wsqd.Range(E29).Value
      wsz.Cells(l_zeile, c_RevSP_F29).Value = wsqd.Range(F29).Value
      wsz.Cells(l_zeile, c_RevSP_G29).Value = wsqd.Range(G29).Value
      wsz.Cells(l_zeile, c_RevSP_H29).Value = wsqd.Range(H29).Value
      
    End Function
    
    Private Function ZielmappeAnlegen(wbz As Workbook, wsz As Worksheet)
      
      Dim x As Long, z As Long
      
     ->Ziel-Mappe anlegen
      Set wbz = Workbooks.Add
      For x = wbz.Worksheets.Count To 2 Step -1
        Application.DisplayAlerts = False
        wbz.Worksheets(x).Delete
        Application.DisplayAlerts = True
      Next
    
      Set wsz = wbz.Worksheets(1)
      
      z = c_RevZ_Ueberschrift
      
      With wsz.Cells(z, c_RevSP_Verz)
        .Value = c_RevSP_Verz_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_Datei)
        .Value = c_RevSP_Datei_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_E10)
        .Value = c_RevSP_E10_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_G8)
        .Value = c_RevSP_G8_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_D5)
        .Value = c_RevSP_D5_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_H2)
        .Value = c_RevSP_H2_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_B3)
        .Value = c_RevSP_B3_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_D6)
        .Value = c_RevSP_D6_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_B29)
        .Value = c_RevSP_B29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_C29)
        .Value = c_RevSP_C29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_D29)
        .Value = c_RevSP_D29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_E29)
        .Value = c_RevSP_E29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_F29)
        .Value = c_RevSP_F29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_G29)
        .Value = c_RevSP_G29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_H29)
        .Value = c_RevSP_H29_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_Verantw)
        .Value = c_RevSP_Verantw_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrK)
        .Value = c_RevSP_BewKrK_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrB)
        .Value = c_RevSP_BewKrB_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrF)
        .Value = c_RevSP_BewKrF_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrP)
        .Value = c_RevSP_BewKrP_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrO)
        .Value = c_RevSP_BewKrO_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrI)
        .Value = c_RevSP_BewKrI_TXT: .Font.Bold = True
      End With
      With wsz.Cells(z, c_RevSP_BewKrandere)
        .Value = c_RevSP_BewKrandere_TXT: .Font.Bold = True
      End With
    
    End Function
     
  10. und hier Modul 2 und 3:


    Modul2:
    Code:
    Option Explicit
    Type myFiles_structure
      s_Verzeichnis As String
      s_Dateiname   As String
      s_VollerPafd  As String
    End Type
    
    '********************************************************************************
    Function ReviewFilesSuchen(s_SuchPfad As String, s_DateiMuster As String, _
                                        f() As myFiles_structure, f_cnt As Long) As Boolean
    '*** Im Pfad und seinen Unterverzeichnissen wird
    '*** nach Musterdateien (Review*.xls) gesucht
    '***
    '*** Die gefundenen Files werden in Feld f() myFiles_structure
    '*** zurückgegeben.
    '***
    '*** Die Anzahl der zurückgegeben files ist in f_cnt enthalten
    '***
    '********************************************************************************
    
      Dim s_QuellDatei As String, s_Pfad As String, s_Dateiname As String, x As Long
    
     ->Rückgabekennung OK
      ReviewFilesSuchen = True
    
     ->Rückgabefeld und -zähler initialisieren
      ReDim f(1 To 1): f_cnt = 0
      
     ->Pfad überprüfen
      If Dir(s_SuchPfad, vbDirectory) =  Then
        MsgBox (Suchpfad nicht vorhanden & vbLf & s_SuchPfad)
        ReviewFilesSuchen = False
        Exit Function
      End If
      
    
      With Application.FileSearch
        .NewSearch
        .LookIn = s_SuchPfad
        .SearchSubFolders = True
        .FileName = s_DateiMuster
       ->.FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
          For x = 1 To .FoundFiles.Count
            s_QuellDatei = .FoundFiles(x)
           ->Dateinamen und Pfad aus s_QuellDatei
            Call DateinameUndPfadTrennen(s_QuellDatei, s_Pfad, s_Dateiname)
           ->Vollen Pfad, Pfad, Dateiname in Feld speichern
            f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
            f(f_cnt).s_VollerPafd = s_QuellDatei
            f(f_cnt).s_Verzeichnis = s_Pfad
            f(f_cnt).s_Dateiname = s_Dateiname
          Next x
          If f_cnt = 0 Then
            MsgBox (Es wurden keine Files mit dem Datei-Muster & vbLf & s_DateiMuster & vbLf & gefunden.)
            ReviewFilesSuchen = False
            Exit Function
          End If
        Else
          MsgBox (Es wurden keine Files mit dem Datei-Muster & vbLf & s_DateiMuster & vbLf & gefunden.)
          ReviewFilesSuchen = False
          Exit Function
        End If
      End With
    End Function
    
    
    '********************************************************************
    Private Function DateinameUndPfadTrennen(s_QuellDatei As String, s_Pfad As String, s_Dateiname As String)
    
      Dim x As Long, s As String
      
      s_Pfad = s_QuellDatei
      s_Dateiname = 
      
      For x = Len(s_QuellDatei) To 2 Step -1
        s = Mid(s_QuellDatei, x, 1)
        Select Case s
          Case \
            s_Dateiname = Right(s_QuellDatei, Len(s_QuellDatei) - x)
            s_Pfad = Left(s_QuellDatei, x - 1)
            Exit For
        End Select
      Next
    
    End Function
    Modul3:
    Code:
    Option Explicit
    
    Public Type typ_BrowseInfo
        hOwner       As Long
        pidlRoot     As Long
        pszDispName  As String
        lpszTitle    As String
        ulFlags      As Long
        lpfn         As Long
        lParam       As Long
        iImage       As Long
    End Type
    
    Public Declare Function GetDesktopWindow Lib user32 () As Long
    Public Declare Function SHBrowseForFolder Lib shell32.dll Alias _
                           SHBrowseForFolderA (lpBrowseInfo As typ_BrowseInfo) As Long
    Public Declare Function SHGetPathFromIDList Lib shell32.dll Alias _
                           SHGetPathFromIDListA (ByVal pidl As Long, ByVal pszPath As String) As Long
    Public Declare Sub CoTaskMemFree Lib OLE32.dll (ByVal pv As Long)
    
    '********************************************************************
    Public Function VerzeichnisAuswahl(Optional s_DialgTitel As String = vbNullString) As String
    ' Ruft den Verzeichnisauswahldialog auf
    ' Eingang: s_DialgTitel - optionaler Dialogtitel
    ' Retrun : ausgewählter Ordner
    '********************************************************************
        Dim BI As typ_BrowseInfo, lPidl As Long, sPath As String * 260
        
        On Error Resume Next
        BI.hOwner = GetDesktopWindow()
        BI.pidlRoot = 0&
        BI.ulFlags = &H1->BIF_RETURNONLYFSDIRS
        If Len(s_DialgTitel) = 0 Then BI.lpszTitle = Bitte wählen Sie ein Verzeichnis: _
                                 Else BI.lpszTitle = s_DialgTitel
        lPidl = SHBrowseForFolder(BI)
        If SHGetPathFromIDList(ByVal lPidl, ByVal sPath) Then _
            VerzeichnisAuswahl = VBA.Left(sPath, VBA.InStr(sPath, vbNullChar) - 1)
        Call CoTaskMemFree(lPidl)
        On Error GoTo 0
    End Function
    
    Private Function Test_VerzeichnisAuswahl()
      Dim s_tmp As String
      s_tmp = VerzeichnisAuswahl(Mein Dialog)
    
    End Function
     
Die Seite wird geladen...

Excel: Verzeichnis durchsuchen und aus Dateien bestimmte Felder übernehmen - Ähnliche Themen

Forum Datum
Excel-Feature gesucht Microsoft Office Suite 11. Okt. 2016
Excel Tabelle Werte zu ordnen Microsoft Office Suite 23. Sep. 2016
Excel: Bereiche auf 'leer' Überprüfen Microsoft Office Suite 15. Sep. 2016
Import Datensatz inkl = und - Zeichen in Excel/Libre CALC Software: Empfehlungen, Gesuche & Problemlösungen 20. Mai 2016
Bestimmter User kann seine Excel Dateien nicht mehr direkt öffnen Software: Empfehlungen, Gesuche & Problemlösungen 16. Apr. 2016