Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Suche und Listen in mehreren Arbeitsmappen
29.10.2013 08:50:38
Climbi
Hallo,
ich möchte in einem bestimmten Verzeichnis alle Excelmappen mit dem
Namen "Protoll_***.xlsm" dursuchen und alle Einträge, welche in einer bestimmten
Spalte dem Suchtext entsprechen, auflisten.
Muss ich da per VBA jede Mappe öffnen und durchsuchen, oder gibt es hierfür eine ganz andere Möglichkeit?
Bin für jeden Ansatz dankbar.
Gruß Climbi

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suche und Listen in mehreren Arbeitsmappen
29.10.2013 17:17:57
Pepi
Hallo Climbi
hier ist ein Code, der genau das macht - der Kerncode ist natürlich viel kürzer
Jede Arbeitsmappe wird geöffnet, ausgelesen und wieder geschlossen - funktionier sehr gut und relativ schnell - viel Spass beim umbauen es Makros
Pepi
Sub SU_AD_Zusammenfassen()
Dim sPfa As String, sAktPfa As String, sFil As String, sAnt As String
Dim z As Integer, s As Integer, zI As Long, sI As Integer, j As Integer, k As Integer, iVon As  _
Integer, iAnz As Integer
Dim iZeiBas As Long, iZei As Long, iSpaBa1 As Integer, iSpaBa2 As Integer
Dim iZeiImp As Long, iSpaIm1 As Integer, iSpaIm2 As Integer, iFar As Variant, xX As Integer
Dim oWB1 As Object, oWB2 As Object, oTC3 As Object, oTC9 As Object, sFP As String, iNum As  _
Integer, sTmp As String
Dim sJaMo As String, sJa As String, sMo As String
On Error GoTo Fehler
' Das DatenDirectory setzen
iExt = 99
Set oTC3 = Tab03.Cells()
Set oTC9 = Tab99.Cells()
sJaMo = FU_JaMo(oTC9(7, 24), 0, 0) 'Mid(Tab01.Name, 5, 7)
sTmp = Trim(InputBox("Bitte Dateidatum eingeben - JJJJ_MM", "Objektmeldungen retour von AD_" &  _
sJaMo, sJaMo))
If sTmp = "" Then Exit Sub
sJaMo = sTmp
'Stop
If sTmp  FU_JaMo(sJaMo, 0, 0) Then
MsgBox sTmp & " ist ein ungültiges Datum - Abbruch!", vbExclamation
Exit Sub
End If
sPfa = Trim(oTC9(5, 24)) & " " & sJaMo & "\" 'an Fachpartner
If FU_Ordner_Vorhanden(sPfa) Then _
MsgBox "Pfad" & vbLf & vbTab & sPfa & vbLf & vbLf & "bereits vorhanden - Abbruch!",  _
vbExclamation: Exit Sub
sPfa = Trim(oTC9(4, 24)) & " " & sJaMo & "\" 'Retur von AD
If Not FU_Ordner_Vorhanden(sPfa) Then _
MsgBox "Pfad" & vbLf & vbTab & sPfa & vbLf & vbLf & "konnte nicht gefunden werden - Abbruch!" _
, vbExclamation: Exit Sub
Set oWB2 = Workbooks(ThisWorkbook.Name).Sheets(Tab03.Name).Cells()
Call SU_Kopfzeile(Tab03, 43, 1, 2)
'Workbooks(ThisWorkbook.Name).Sheets(Tab03.Name).Range("A1:" & Chr(FU_SpalteO(Tab03, 1) + 64) &  _
"1").Interior.Color = 10092441 'hellgrün
iFar = Array(37, 38)
Tab03.Name = "O-Meldungen_" & sJaMo
'bestehende Daten löschen
Tab03.Activate
iZeiBas = FU_Zeilen(1)
iSpaBa2 = FU_Spalten(1)
If iZeiBas > 1 Then Rows("2:" & CStr(iZeiBas)).Delete Shift:=xlUp
If iSpaBa2 > 11 Then Range(Columns(12), Columns(iSpaBa2)).Delete Shift:=xlToLeft
' Start des eigentlichen Programms
ChDrive ("N:")
ChDir sPfa
iZei = 1
' Files in "Objektmeldungen retour von AD ..." mit "Objektmeldungen an AD ..." vergleichen 16. _
08.10
sTmp = Trim(oTC9(3, 24)) & " " & sJaMo                 'Objektmeldungen an AD 2010_07"
sFil = Dir(sTmp & "\*.xls")
z = 2
Range("A2:G20").Select
Selection.ClearContents
Selection.Interior.ColorIndex = xlNone
Cells(z, 1) = "..." & Right(sTmp, InStr(StrReverse(sTmp), "\"))
Do Until sFil = ""                                      'an AD einlesen
z = z + 1
Cells(z, 1) = sFil
Range(Cells(z, 1), Cells(z, 2)).Interior.ColorIndex = 37
sFil = Dir
Loop
iAnz = z
sTmp = Trim(oTC9(4, 24)) & " " & sJaMo                  'Objektmeldungen retour von AD 2010_07"
sFil = Dir(sTmp & "\*.xls")
z = 2: j = 0
Cells(z, 4) = ".." & Right(sTmp, InStr(StrReverse(sTmp), "\"))
Do Until sFil = ""                                      'retour von AD einlesen
For z = 2 To iAnz
If FU_FileName(Cells(z, 1)) = FU_FileName(sFil) Then  'Endung abtrennen
Cells(z, 4) = sFil
Rows(z).Interior.ColorIndex = xlNone
Exit For
End If
Next z
If z > iAnz Then
j = j + 1
Cells(iAnz + j, 4) = sFil
End If
sFil = Dir
Loop
Rows(2).Font.Bold = True
Range(Cells(2, 1), Cells(iAnz + j, 4)).Font.Size = 10
iAnz = FU_Zeilen(1, 4)
If iAnz  Cells(z, 4) Then
If Left(Cells(z, 1), InStr(Cells(z, 1), "."))  Left(Cells(z, 4), InStr(Cells(z, 4), "."))  _
Then
Range(Cells(z, 4), Cells(z, 5)).Interior.ColorIndex = 38
j = j + 1
End If
Next z
If j > 0 Then
Cells(2, 7).Select
MsgBox "Es gibt " & j & " Unterschiede beim Vergleichen von " & vbLf & vbLf & vbTab & Cells( _
2, 1) & vbLf & "mit" & vbLf & vbTab & Cells(2, 4)
Exit Sub
End If
Application.ScreenUpdating = False
Rows(2).Font.Bold = False
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'MsgBox "Makro muss ende Mai angepasst werden - bitte Peter Egloff kontaktieren!",  _
vbExclamation
'Achtung in Zeile 127 bereits Aenderungen gemacht - 9.04.13
'Exit Sub
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
' Alle Files in dem Datendirectory einlesen
sFil = Dir(sPfa & "\*.xls")
Do Until sFil = ""
'If InStr(LCase(sFil), "ams") Then ' iSpaBa2 Then
oWB2(1, iSpaBa2 + 1) = sFP
Columns(iSpaBa2 + 1).ColumnWidth = 2
End If
Next sI
Range(oWB2(1, iVon), oWB2(1, FU_Spalten(1))).Interior.ColorIndex = iFar(iAnz Mod 2)
Range(oWB2(1, 12), oWB2(1, FU_Spalten(1))).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
End With
With Selection.Font
.Name = "Arial"
.Size = 8
End With
' ------------------------------------------------------------------------------------------- _
'Daten einlesen
iSpaBa2 = FU_Spalten(1)
For zI = xX To iZeiImp  '4
iZei = iZei + 1
Range(oWB1(zI, 1), oWB1(zI, 11)).Copy
oWB2(iZei, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
sTmp = oWB2(iZei, 1)
j = InStr(sTmp, Chr(10))               '1.) Positionierunng abschneiden
If j > 0 And j  "" Then '= "x" Then - nicht immer "x", ect. "xx"
sFP = oWB1(xX - 1, sI) '3
For s = 12 To iSpaBa2
If sFP = oWB2(1, s) Then
oWB2(iZei, s) = "x"
Exit For
End If
Next s
If s > iSpaBa2 Then MsgBox ">" & sFP & " 10 And s > 10 Then
Range(Cells(1, 1), Cells(z, s)).Select ' ganzer Sortierbereich markieren
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(1, 2), Cells(z, 2)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Range(Cells(1, 1), Cells(z, s))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
' Tabelle formatieren
Application.StatusBar = "Tabelle formatieren"
iZeiBas = FU_Zeilen(2)
iSpaBa2 = FU_Spalten(1)
Range(oWB2(1, 1), oWB2(iZeiBas, iSpaBa2)).Select   'Ganze Tabelle
With Selection.Font
.Name = "Arial"
.Size = 8
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
End With
Selection.Borders(xlEdgeLeft).Weight = xlThin
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideHorizontal).Weight = xlThin 'wenn hier Fehler, dann geht  _
vermutlich die Formatierung nicht!! 25.10.10
Range(oWB2(1, 1), oWB2(1, iSpaBa2)).Select   'Kopfzeile
Selection.Font.Bold = True
Selection.VerticalAlignment = xlCenter
'Range(oWB2(1, 1), oWB2(1, 1)).Interior.ColorIndex = 44   'Kopfzeile
Range(oWB2(1, 12), oWB2(iZeiBas, iSpaBa2)).HorizontalAlignment = xlCenter  'FP-Namen mit "x"
Range(oWB2(1, 12), oWB2(1, iSpaBa2)).Select  'FP-Namen (Titel)
With Selection
'.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
'.Interior.ColorIndex = 6              'gelb
End With
Range(oWB2(1, 12), oWB2(1, iSpaBa2)).Font.Bold = False
Range(oWB2(1, 1), oWB2(iZeiBas, 1)).HorizontalAlignment = xlLeft
Range(oWB2(1, 9), oWB2(iZeiBas, 10)).HorizontalAlignment = xlCenter  'CHF, CRB-Code
Tab03.Name = "O-Meldungen-" & sJaMo
'oTC9(7, 24) = FU_JaMo(sJaMo, 1)            'JJJJ_MM einlesen (1 erhöhen) - erst mit  _
FP_erstellen Ein höher setzen
Application.ScreenUpdating = True
Application.StatusBar = ""
oWB2(2, 1).Select
iExt = 0
Exit Sub
Fehler:
MsgBox "SU_AD_Zusammenfassen() - Nicht verzagen - Peter Egloff fragen!", vbQuestion
End 

Sub ' SU_AD_Zusammenfassen()

Sub SU_AD_Formatieren()
Dim z As Long, s As Integer, i As Integer, j As Integer, k As Integer, m As Integer, n As  _
Integer
Dim iZeiAnz As Integer
Dim sTxt As String, sZ As String, sZ4 As String, sPLZ As String, sCel As String
On Error GoTo Fehler
Application.ScreenUpdating = False
iZeiAnz = FU_Zeilen(1)
If iZeiAnz = 6 Then                       'mindestens "1.2.05"
Cells(z, s).Value = Format(Day(sTxt), "00") & "." _
& Format(Month(sTxt), "00") & "." & Right(Year(sTxt), 2)
End If
Case 8                                          'Start/Ende
sTxt = ""
sCel = Cells(z, 8).Value
If Len(sCel) > 4 Then sTxt = FU_Beginn_Ende(sCel)
If sCel  sTxt Then Cells(z, 8) = sTxt
Case Else
sTxt = ""
For k = 1 To Len(Cells(z, s).Value)          'Ganzer String innerhalb Zelle
sZ = Right(Left(Cells(z, s).Value, k), 1) 'aktuelles Zeichen
sZ4 = Right(Left(Cells(z, s).Value, k + 4), 1)  '4 Zeichen danach
sPLZ = Right(Left(Cells(z, s).Value, k + 3), 4) 'Mögliche PLZ
'Mehrfache Zeilenumbrüche entfernen
If sZ = Chr(10) Then                            'Zeilenumbrüche entfernen
n = 0
For m = 1 To 5                         '5 Zeichen weiter schauen, ob "CR"  _
vorhanden
If Right(Left(Cells(z, s).Value, k + m), 1) = Chr(10) Then n = n + 1
Next
k = k + n
n = 0
End If
'Konvertiert "5430Wettingen" nach "5430 Wettingen"
If Val(sPLZ) > 1000 And Val(sPLZ) = 65 And Asc(sZ4) 
Sub 'SU_AD_Formatieren()

Anzeige
AW: Suche und Listen in mehreren Arbeitsmappen
30.10.2013 07:11:43
Climbi
Hallo Pepi,
vielen Dank für Deinen Code.
Ich werde mich mal langsam durcharbeiten um ihn zu verstehen.
Ist auf jeden Fall mal ein Anfang :-)
Gruß Climbi

303 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige