AW: Tabellenblätter auslesen KW
25.02.2020 13:17:44
Piet
Hallo
hier mal zwei Makro die das Problem lösen können. Das erste listet die KW in einem neuem Blatt nebeneinander auf, das zweite Makro listet untereinander auf. Den Rest bitzte selbsdt anpassen
mfg Piet
Option Explicit
Sub KW_nebeneinander_auflisten()
Dim j, sp As Integer
Dim Sht As Worksheet
sp = 1 '1. Spalte
With Worksheets("Übersicht") '** ggf. anderen Tabellen Namen angeben
'Übersicht ab Zeile 2 löschen
.UsedRange.Offset(1, 0).ClearContents
'Schleife zum nebeneinander auflisten
For j = 1 To Worksheets.Count
If InStr(Worksheets(j).Name, "KW") Then
Worksheets(j).Range("A4:M10").Copy
.Range("A4").Cells(1, sp).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next j
End With
End Sub
Sub KW_untereinander_auflisten()
Dim j, lz1 As Integer
Dim Sht As Worksheet
With Worksheets("Übersicht") '** ggf. anderen Tabellen Namen angeben
'Übersicht ab Zeile 2 löschen
.UsedRange.Offset(1, 0).ClearContents
'Schleife zum untereinander auflisten
For j = 1 To Worksheets.Count
If InStr(Worksheets(j).Name, "KW") Then
'LastZell in spalte ermitteln
lz1 = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(j).Range("A4:M10").Copy
.Range("A4").Cells(lz1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next j
End With
End With
End Sub