AW: Bestimmte Zellen kopieren wenn
29.02.2020 10:45:09
fcs
Hallo Conny,
hier mein Makrovorschlag.
Muss du ggf. noch ein wenig anpassen.
Da etwas einfacher zu händeln werden Ergebnisse in eine neue Arbeitsmappe übertragen.
Das Tabellenblatt kannst du ggf. in deine Datei kopieren.
LG
Franz
Sub UebertragenWerte()
Dim wkb_Q As Workbook, wks_Q As Worksheet
Dim wkb_Z As Workbook, wks_Z As Worksheet
Dim Zei_Z As Long
Dim Zeile_Q As Long
Dim spaCheck As Long
Dim spaCopy1 As Long, spaCopy2 As Long
Dim StatusCalc As Long
Dim varwert As Variant
varwert = InputBox("Bitte den zu suchenden Wert eingeben", "Auswerten Jahresdaten")
If varwert = "" Then GoTo Beenden 'Eingabe wurde abgebrochen
Set wkb_Q = ActiveWorkbook 'Abeitsmappe mit den vielen Blätter und Daten
'Tabellenblätter in Quelldatei abarbeiten
Zeile_Q = 32 'Zeile mit den zu prüfenden/kopierenden Daten
spaCheck = 9 'Spalte I
spaCopy1 = 10 'Spalte J - 1. zu kopierende Spalte
spaCopy2 = 14 'Spalte N - letzte zu kopierende Spalte
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
For Each wks_Q In wkb_Q.Worksheets
With wks_Q
If .Cells(Zeile_Q, spaCheck).Value = varwert Then
If wkb_Z Is Nothing Then
'neue Mappe mit 1 Blatt für Ergebnisse erstellen
Set wkb_Z = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wks_Z = wkb_Z.Worksheets(1)
'Zielblatt aufbereiten/formatieren
Zei_Z = 1
wks_Z.Cells(Zei_Z, 1) = "Auswertung 2012 für Wert " & varwert
Zei_Z = 3
'Spaltentitel
wks_Z.Cells(Zei_Z, 1).Value = "Spa J"
wks_Z.Cells(Zei_Z, 2).Value = "Spa K"
wks_Z.Cells(Zei_Z, 3).Value = "Spa L"
wks_Z.Cells(Zei_Z, 4).Value = "Spa M"
wks_Z.Cells(Zei_Z, 5).Value = "Spa N"
wks_Z.Cells(Zei_Z, 6).Value = "Blattname"
'Spaltenbreiten
.Range(.Cells(Zeile_Q, spaCopy1), .Cells(Zeile_Q, spaCopy2)).Copy
wks_Z.Cells(Zei_Z, 1).PasteSpecial Paste:=xlPasteColumnWidths
Range("A4").Select
ActiveWindow.FreezePanes = True
End If
Zei_Z = Zei_Z + 1
.Range(.Cells(Zeile_Q, spaCopy1), .Cells(Zeile_Q, spaCopy2)).Copy
wks_Z.Cells(Zei_Z, 1).PasteSpecial Paste:=xlPasteFormats
wks_Z.Cells(Zei_Z, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
wks_Z.Cells(Zei_Z, 6) = wks_Q.Name
End If
End With
Next wks_Q
If Not wks_Z Is Nothing Then
With wks_Z
.Columns(6).AutoFit
.Range(.Cells(Zei_Z, 1), .Cells(Zei_Z, spaCopy2 - spaCopy1 + 1)).Copy
'Summenformel einfügen
Zei_Z = Zei_Z + 1
'Summenzeile fomatieren
.Range(.Cells(Zei_Z, 1), .Cells(Zei_Z, spaCopy2 - spaCopy1 + 1)) _
.PasteSpecial Paste:=xlPasteFormats
.Cells(Zei_Z, 6) = "Summe"
.Range(.Cells(Zei_Z, 1), .Cells(Zei_Z, spaCopy2 - spaCopy1 + 1)).FormulaR1C1 = _
"=SUM(R4C:R[-1]C)"
End With
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
MsgBox "Auswertung fertig"
Else
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
MsgBox "Keine Daten zu dem gesuchten Wert """ & varwert & """ gefunden!"
End If
Beenden:
End Sub