Office: (Office 2010) Wenn Zelle leer dann nächste.

Taipan1987 · 19. August 2017

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.
Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

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? *biggrin.gif* 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 · 20. August 2017

Hallo?,

Wenn eine der betroffenen Zeilen die das Makro kopieren soll leer ist bleibt das Makro stehen.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

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?

Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

Fennek11 · 20. August 2017

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 · 20. August 2017

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:

Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ungetestet!!!

Taipan1987 · 20. August 2017

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 · 20. August 2017

\@Edgar

Es müssen in den Zellen O54 bis O87 Zellbezeichnungen stehen, sonst funktioniert das nicht.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Korrekt. Daher noch mit Test, ob eine gültige Zelladresse vorliegt:
Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

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

versuche möglichst große Range auf einmal zu kopieren,
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ja, das wäre der Leistung in der Tat zuträglich.

Grüße
EarlFred

Taipan1987 · 20. August 2017

Hammer funktioniert wie gewünscht.
Ich danke und verbeuge mich vor deinen VBA Künsten

EarlFred · 20. August 2017

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

BoskoBiati · 20. August 2017

Hi,

ginge auch so:

Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Taipan1987 · 20. August 2017

Achso kann ich noch irgendwie das mit dem August automatisieren ? Im Ziel Workbook sind Worksheets nach Monat angelegt.

Office: (Office 2010) Wenn Zelle leer dann nächste.

Wenn Zelle leer dann nächste.

Wenn Zelle leer dann nächste.

Wenn Zelle leer dann nächste.

Wenn Zelle leer dann nächste.

Wenn Zelle leer dann nächste. - Similar Threads - Zelle

Eine Zelle blinken lassen

Daten Einlesen aus mehre Zellen in Verbindung einer Verbundene Zelle

Hochzählen Zelle Excel oder Office365?

Zelleninhalte in andere Zelle mit Komma getrennt

In einer Zelle Zahlen erkennen und trennen

Formularsteuerelement Textfeld: Selbe Formatierung wie verlinkte Zelle?

Teilstring einer Zelle auf Wert aus anderer Zelle überprüfen