PDA

Vollständige Version anzeigen : Wenn Zelle leer dann nächste.


Taipan1987
21.08.2017, 08:17
Hi Leute ich hab mal wieder ein Problem ^^

Ich hab eine riesen Formel die sicher auch leichter geht aber ich konnte mir noch nicht anders helfen denn ich weiß nicht wie.
Sub Kopier_Test1()

Dim Wert1 As String
Dim Wert2 As String
Dim Wert3 As String
Dim Wert4 As String
Dim Wert5 As String
Dim Wert6 As String
Dim Wert7 As String
Dim Wert8 As String
Dim Wert9 As String
Dim Wert10 As String
Dim Wert11 As String
Dim Wert12 As String
Dim Wert13 As String
Dim Wert14 As String
Dim Wert15 As String
Dim Wert16 As String
Dim Wert17 As String
Dim Wert18 As String
Dim Wert19 As String
Dim Wert20 As String
Dim Wert21 As String
Dim Wert22 As String
Dim Wert23 As String
Dim Wert24 As String
Dim Wert25 As String
Dim Wert26 As String
Dim Wert27 As String
Dim Wert28 As String
Dim Wert29 As String
Dim Wert30 As String
Dim Wert31 As String
Dim Wert32 As String
Dim wert33 As String
Dim wert34 As String

Wert1 = Sheets("Tabelle1").Range("O54")
Wert2 = Sheets("Tabelle1").Range("O55")
Wert3 = Sheets("Tabelle1").Range("O56")
Wert4 = Sheets("Tabelle1").Range("O57")
Wert5 = Sheets("Tabelle1").Range("O58")
Wert6 = Sheets("Tabelle1").Range("O59")
Wert7 = Sheets("Tabelle1").Range("O60")
Wert8 = Sheets("Tabelle1").Range("O61")
Wert9 = Sheets("Tabelle1").Range("O62")
Wert10 = Sheets("Tabelle1").Range("O63")
Wert11 = Sheets("Tabelle1").Range("O64")
Wert12 = Sheets("Tabelle1").Range("O65")
Wert13 = Sheets("Tabelle1").Range("O66")
Wert14 = Sheets("Tabelle1").Range("O67")
Wert15 = Sheets("Tabelle1").Range("O68")
Wert16 = Sheets("Tabelle1").Range("O69")
Wert17 = Sheets("Tabelle1").Range("O70")
Wert18 = Sheets("Tabelle1").Range("O71")
Wert19 = Sheets("Tabelle1").Range("O72")
Wert20 = Sheets("Tabelle1").Range("O73")
Wert21 = Sheets("Tabelle1").Range("O74")
Wert22 = Sheets("Tabelle1").Range("O75")
Wert23 = Sheets("Tabelle1").Range("O76")
Wert24 = Sheets("Tabelle1").Range("O77")
Wert25 = Sheets("Tabelle1").Range("O78")
Wert26 = Sheets("Tabelle1").Range("O79")
Wert27 = Sheets("Tabelle1").Range("O80")
Wert28 = Sheets("Tabelle1").Range("O81")
Wert29 = Sheets("Tabelle1").Range("O82")
Wert30 = Sheets("Tabelle1").Range("O83")
Wert31 = Sheets("Tabelle1").Range("O84")
Wert32 = Sheets("Tabelle1").Range("O85")
wert33 = Sheets("Tabelle1").Range("O86")
wert34 = Sheets("Tabelle1").Range("O87")

ThisWorkbook.Sheets("Tabelle1").Range("H54:I54").Copy
Workbooks.Open Filename:="D:Data11213065DesktopLFZAUSW KOPIE TESTLFZSTD 17.xlsm", ReadOnly:=False
ActiveWorkbook.Sheets("August 17").Range(Wert1).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H55:I55").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert2).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H56:I56").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert3).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H57:I57").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert4).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H58:I58").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert5).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H59:I59").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert6).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H60:I60").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert7).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H61:I61").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert8).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H62:I62").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert9).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H63:I63").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert10).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H64:I64").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert11).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H65:I65").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert12).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H66:I66").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert13).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H67:I67").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert14).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H68:I68").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert15).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H69:I69").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert16).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H70:I70").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert17).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H71:I71").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert18).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H72:I72").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert19).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H73:I73").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert20).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H74:I74").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert21).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H75:I75").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert22).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H76:I76").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert23).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H77:I77").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert24).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H78:I78").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert25).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H79:I79").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert26).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H80:I80").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert27).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H81:I81").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert28).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H82:I82").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert29).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H83:I83").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert30).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H84:I84").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert31).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H85:I85").Copy
ActiveWorkbook.Sheets("August 17").Range(Wert32).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H86:I86").Copy
ActiveWorkbook.Sheets("August 17").Range(wert33).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Tabelle1").Range("H87:I87").Copy
ActiveWorkbook.Sheets("August 17").Range(wert34).PasteSpecial xlPasteValues

End Sub
So hier mein Problem: Wenn eine der betroffenen Zeilen die das Makro kopieren soll leer ist bleibt das Makro stehen. Ich würde das gerne mit einem IF THEN Code lösen nur weiß ich nicht wie da ich nicht so bewandert bin in VBA. Und falls jemand das vielleicht alles vereinfach könnte? :D Mein Makro kopiert halt die zwei zeilen und setzt die Daten in einem anderen Workbook in die Zeile die ich ihr im "Wert" vorgebe.

EarlFred
21.08.2017, 08:31
Hallo?,

Wenn eine der betroffenen Zeilen die das Makro kopieren soll leer ist bleibt das Makro stehen.
was heißt "bleibt stehen"? Hört er einfach auf oder gibt es eine Fehlermeldung? Wenn ja: Wie heißt die, welche Nummer hat die, in welcher Zeile tritt der Fehler auf?

Option Explicit

Sub Kopier_Test1()

Dim fWerte As Variant, i As Long
Dim wbZiel As Workbook

fWerte = ThisWorkbook.Worksheets("Tabelle1").Range("O54:O87").Value

Set wbZiel = Workbooks.Open(Filename:="D:\Data11213065\Desktop\LFZAUSW KOPIE TESTLFZSTD 17.xlsm", ReadOnly:=False)

For i = LBound(fWerte, 1) To UBound(fWerte, 1)
If Not IsEmpty(fWerte(i, 1)) Then
ThisWorkbook.Worksheets("Tabelle1").Range("H54:I54").Offset(i - 1, 0).Copy
wbZiel.Worksheets("August 17").Range(fWerte(i, 1)).PasteSpecial xlPasteValues
End If
Next i

Set wbZiel = Nothing
End Sub

Grüße
EarlFred

Fennek11
21.08.2017, 08:32
Hallo,

versuche möglichst große Range auf einmal zu kopieren, z.B. Range("H54:I87").copy

Als ersten Eindruck sind die "dim" und "Wert2" überflüssig.

mfg

(Es ist zu mühsam, diese vielen Zeilen zu lesen)

BoskoBiati
21.08.2017, 08:34
Hi,

das ist ja wohl keine Formel, sondern ein Makro. Es müssen in den Zellen O54 bis O87 Zellbezeichnungen stehen, sonst funktioniert das nicht. Es wäre hilfreich, wenn Du einen Auszug Deiner Tabelle vorstellen könntest.
Auf jeden Fall könnte man den Code mit einer Schleife vereinfachen:

Sub Kopier_Test1()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksQ As Worksheet
Dim i As Long

Set wksQ = Sheets("Tabelle1")
Set wkb = Workbooks.Open("D:Data11213065DesktopLFZAUSW KOPIE TESTLFZSTD 17.xlsm")
Set wks = wkb.Sheets("August 17")
For i = 54 To 87
Sheets("Tabelle1").Range(Cells(i, 8), Cells(i, 9)).Copy
wks.Range(wksQ.Cells(i, 17)).PasteSpecial xlPasteValues
Next
End Sub

ungetestet!!!

Taipan1987
21.08.2017, 08:37
Also der Fehler ist ein Laufzeitfehler '1004':
Anwendungs- oder objektdefinierter Fehler

und dann makiert er beim Debuggen die Zeile AchtiveWorkbook.Sheets("August 17").Range(wert5).PasteSpecial xlPasteValues

Bild mal angehängt.

EarlFred
21.08.2017, 08:40
@Edgar
Es müssen in den Zellen O54 bis O87 Zellbezeichnungen stehen, sonst funktioniert das nicht.
Korrekt. Daher noch mit Test, ob eine gültige Zelladresse vorliegt:
Option Explicit

Sub Kopier_Test1()

Dim fWerte As Variant, i As Long
Dim wbZiel As Workbook

fWerte = ThisWorkbook.Worksheets("Tabelle1").Range("O54:O87").Value

Set wbZiel = Workbooks.Open(Filename:="D:\Data11213065\Desktop\LFZAUSW KOPIE TESTLFZSTD 17.xlsm", ReadOnly:=False)

For i = LBound(fWerte, 1) To UBound(fWerte, 1)
If Not IsEmpty(fWerte(i, 1)) And IsAddress(fWerte(i, 1)) Then
ThisWorkbook.Worksheets("Tabelle1").Range("H54:I54").Offset(i - 1, 0).Copy
wbZiel.Worksheets("August 17").Range(fWerte(i, 1)).PasteSpecial xlPasteValues
End If
Next i

Set wbZiel = Nothing
End Sub


Function IsAddress(ByRef vAddress As Variant) As Boolean
Dim cTemp As Range
On Error Resume Next
Set cTemp = ThisWorkbook.Worksheets(1).Range(vAddress)
IsAddress = Err = 0 And Not cTemp Is Nothing
Set cTemp = Nothing
End Function

@TE: Mit "Tabellen" / "Mustermappen" sind Exceltabellen / -mappen gemeint, keine Bilder davon...

versuche möglichst große Range auf einmal zu kopieren,
ja, das wäre der Leistung in der Tat zuträglich.

Grüße
EarlFred

Taipan1987
21.08.2017, 08:43
Hammer funktioniert wie gewünscht.
Ich danke und verbeuge mich vor deinen VBA Künsten <3

@EarlFred willst du die immernoch ?

EarlFred
21.08.2017, 08:47
nö. Das war nur ein grundsätzlicher Hinweis, dass Bilder (i. d. R.) nicht zielführend sind.

BoskoBiati
21.08.2017, 08:52
Hi,

ginge auch so:

Sub Kopier_Test1()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksQ As Worksheet
Dim i As Long

Set wksQ = Sheets("Tabelle1")
Set wkb = Workbooks.Open("D:Data11213065DesktopLFZAUSW KOPIE TESTLFZSTD 17.xlsm")
Set wks = wkb.Sheets("August 17")
For i = 54 To 87
If wksQ.Cells(i, 15) <> "" Then
Sheets("Tabelle1").Range(Cells(i, 8), Cells(i, 9)).Copy
wks.Range(wksQ.Cells(i, 15)).PasteSpecial xlPasteValues
End If
Next
End Sub

Taipan1987
21.08.2017, 08:54
Achso kann ich noch irgendwie das mit dem August automatisieren ? Im Ziel Workbook sind Worksheets nach Monat angelegt.