Thema: Reiter kopieren wenn 1 oder 2 oder beides WAHR

Hallo liebe VBA Gemeinde,
folgendes Problem versuche ich zu lösen:
Es sollen die Reiter summary, consolidate und Msl2_light immer in eine neue Datei kopiert werden.
Zusätzlich soll auch der Reiter VoucherUsage_VM#1 in diese neuen Datei kopiert werden, wenn in der Zelle K7 = reserved steht.
Gleiches gilt für den Reiter VoucherUsage_NAS, mit gleicher Abfrage in gleicher Zelle.
Funktioniert soweit super.
Nun kann aber auch in beiden angesprochen Voucher Reitern in K7= reserved enthalten sein, sodass beide Reiter in die neuen Datei kopiert werden sollen.
Da klemmt es.

Mein bisher funktionierender Code für die einzelne Abfrage sieht so aus:

Set wbkAlt = ActiveWorkbook
VM = wbkAlt.Worksheets("VoucherUsage_VM#1").Cells(7, 11) = "reserved" '--wahr oder falsch
NAS = wbkAlt.Worksheets("VoucherUsage_NAS").Cells(7, 11) = "reserved" '--wahr oder falsch

If VM Then
wbkAlt.Worksheets(Array("summary", "consolidate", "Msl2_light", "VoucherUsage_VM#1")).Copy
ElseIf NAS Then
wbkAlt.Worksheets(Array("summary", "consolidate", "Msl2_light", "VoucherUsage_NAS")).Copy
Else
wbkAlt.Worksheets(Array("summary", "consolidate", "Msl2_light")).Copy
End If

Set wbkNeu = ActiveWorkbook
If VM Then
With wbkNeu.Worksheets("VoucherUsage_VM#1").UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.Cells.FormatConditions.Delete
End With
End If

If NAS Then
With wbkNeu.Worksheets("VoucherUsage_NAS").UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.Cells.FormatConditions.Delete
End With
End If

With wbkNeu.Worksheets("Msl2_light").UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.Cells.FormatConditions.Delete
End With

With wbkNeu.Worksheets("consolidate").UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.Cells.FormatConditions.Delete
End With

With wbkNeu.Worksheets("summary").UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.Cells.FormatConditions.Delete
End With

Hallo,

Sub abc()

  Dim objWs As Worksheet

  Dim strWs As String

  Dim varWs As Variant

  

  varWs = Split("summary,consolidate,Msl2_light", ",")

  With Worksheets("VoucherUsage_VM#1")

    If .Range("K7").Value = "reserved" Then

      ReDim Preserve varWs(UBound(varWs) + 1)

      varWs(UBound(varWs)) = .Name

    End If

  End With

  With Worksheets("VoucherUsage_NAS")

    If .Range("K7").Value = "reserved" Then

      ReDim Preserve varWs(UBound(varWs) + 1)

      varWs(UBound(varWs)) = .Name

    End If

  End With

  Worksheets(varWs).Copy

  

  For Each objWs In Worksheets

    With objWs.UsedRange

      .Copy

      .PasteSpecial Paste:=xlPasteValues

      .PasteSpecial Paste:=xlPasteFormats

      .Cells.FormatConditions.Delete

    End With

  Next objWs

End Sub

Gruß, Uwe

Hallo Uwe,
danke für deine Antwort, die leider nur zum Teil verstehe.
Vor deinem Code wäre bei mir noch:

Pfad = ThisWorkbook.Path 'Pfad der gerade geöffneten Datei
Name = Worksheets("configuration").Range("a1") & "_" & Format(Date, "yyyymmdd") & "_" & Worksheets("configuration").Range("a2") & ".xlsx
If Dir(ThisWorkbook.Path & "\kit calculation\", vbDirectory) = "" Then MkDir (ThisWorkbook.Path & "\kit calculation\")

Warum, weil die neue Datei dann unter dem o.g. Pfad angelegt oder überschrieben werden soll.
In meinem ursprünglichen Code wurde die neue Datei wie folgt gespeichert:

wbkNeu.SaveAs Filename:=Pfad & "\kit calculation\" & Name, FileFormat:=xlOpenXMLWorkbook
wbkNeu.Close savechanges = True
Set wbkNeu = Nothing
Set wbkAlt = Nothing

Jetzt gibt es in deiner Variante ja kein wbkNeu mehr.
Der Vesuch, wbkneu durch objws zu ersetzen scheiterte, vermutlich da du objws als worksheet definiert hast, ich aber ein Workbook anspreche.
Wie gesagt verstehe ich den Code von dir nicht ganz, da ich keinen Bezug zu einer neuen Datei finde.

danke und vg
torro

Hallo torro,

vor End Sub einfach noch

  ActiveWorkbook.SaveAs Filename:=Pfad & "\kit calculation\" & Name, FileFormat:=xlOpenXMLWorkbook

  ActiveWorkbook.Close

Gruß, Uwe

Hallo Uwe,
das war zu dann doch einfach ;-)
Danke klappt wie gewünscht.
vg
torro

Eine Variante hab ich auch noch. Ungetestet

Sub VVV()

  Dim sh As Worksheet

  

    Set wbkAlt = ActiveWorkbook

    VM = wbkAlt.Worksheets("VoucherUsage_VM#1").Cells(7, 11) = "reserved" '--wahr oder falsch

    NAS = wbkAlt.Worksheets("VoucherUsage_NAS").Cells(7, 11) = "reserved" '--wahr oder falsch



    wbkAlt.Worksheets(Array("summary", "consolidate", "Msl2_light")).Copy

    

    Set wbkneu = ActiveWorkbook

    

    If VM Then

        wbkAlt.Worksheets("VoucherUsage_VM#1").Copy wbkneu

    ElseIf NAS Then

        wbkAlt.Worksheets("VoucherUsage_NAS").Copy wbkneu

    End If



    For Each sh In wbkneu

      With sh.UsedRange

        .Copy

        .PasteSpecial Paste:=xlPasteValues

        .PasteSpecial Paste:=xlPasteFormats

        .Cells.FormatConditions.Delete

      End With

    Next

   

End Sub

Hallo Ralf,
bei deiner Variante markiert er mir folgende Zeile,
obwohl sh als worksheets definiert

For Each sh In wbkneu
vg
torro

versuch mal so For Each sh In wbkneu.Worksheets

Hallo Ralf,
mag er immer noch nicht.
Aber die Variante von Uwe klappt jetzt wie gewünscht.
Danke für deine Mühe.

vg

torro