Re: With-Anweisung mit Bezug
15.02.2003 13:17:39
Nepumuk
Zum besseren Verständnis der komplette Code:Option Explicit
Sub aktuallisieren()
Dim Arbeitsmappe As Workbook, gefunden As Boolean, Tabelle As Worksheet, TabelleI As Worksheet
Dim Tabellennamen As String, Zeile As Long, ZeileI As Long, Spalte As Integer
Application.ScreenUpdating = False
Set Tabelle = ThisWorkbook.Sheets("Namen")
For Each Arbeitsmappe In Workbooks
If Arbeitsmappe.Name = "einzeln.xls" Then gefunden = True: Exit For
Next Arbeitsmappe
If Not gefunden Then Workbooks.Open "D:\Eigene Dateien\Fremde Tabellen\einzeln.xls" Else Workbooks("einzeln.xls").Activate
For Each TabelleI In Workbooks("einzeln.xls").Sheets
TabelleI.Range("A3:K65536").Clear
Tabellennamen = Tabellennamen & TabelleI.Name & ","
Next TabelleI
For Zeile = 3 To Tabelle.Range("A65536").End(xlUp).Row
For Spalte = 2 To 5 Step 3
If InStr(1, Tabellennamen, Tabelle.Cells(Zeile, Spalte)) = 0 Then
Worksheets.Add
ActiveSheet.Name = Tabelle.Cells(Zeile, Spalte)
Tabellennamen = Tabellennamen & Tabelle.Cells(Zeile, Spalte) & ","
Tabelle.Rows("1:2").Copy Cells(1, 1)
End If
With Sheets(CStr(Tabelle.Cells(Zeile, Spalte)))
ZeileI = .Range("A65536").End(xlUp).Row + 1
Tabelle.Rows(Zeile).Copy .Rows(ZeileI)
With .Range(.Cells(ZeileI, 1), .Cells(ZeileI, 11)).Interior
.ColorIndex = 0
If ZeileI Mod 2 = 0 Then .Pattern = xlGray16 Else .Pattern = xlSolid
End With
.Columns.AutoFit
End With
Next
Next
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Workbooks("einzeln.xls").Save
End Sub
Gruß
Nepumuk