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()