Mittels VBA Zellen in anderes Worksheet kopieren

Chris_Haas · 15. April 2008 um 17:44

hallo an alle,

ich habe folgendes problem:

ich kopiere mittels folgendem code einzelne zellen in ein anderes Worksheet:

Private Sub CommandButton5_Click()
Dim Loletzte As Long

Loletzte = IIf(IsEmpty(Worksheets(„Übersicht“).Range(„A65536“)), Worksheets(„Übersicht“).Range(„A65536“).End(xlUp).Row + 1, 65536)
Worksheets(„Übersicht“).Cells(Loletzte, 1) = ActiveSheet.Range(„A15“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 2) = ActiveSheet.Range(„B15“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 4) = ActiveSheet.Range(„E15“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 5) = ActiveSheet.Range(„D5“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 6) = ActiveSheet.Range(„H15“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 7) = ActiveSheet.Range(„E25“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 8) = ActiveSheet.Range(„E24“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 9) = ActiveSheet.Range(„G7“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 10) = ActiveSheet.Range(„G15“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 11) = ActiveSheet.Range(„I15“).Value

Loletzte = IIf(IsEmpty(Worksheets(„Übersicht“).Range(„A65536“)), Worksheets(„Übersicht“).Range(„A65536“).End(xlUp).Row + 1, 65536)
Worksheets(„Übersicht“).Cells(Loletzte, 1) = ActiveSheet.Range(„A16“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 2) = ActiveSheet.Range(„B16“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 4) = ActiveSheet.Range(„E16“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 5) = ActiveSheet.Range(„D5“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 6) = ActiveSheet.Range(„H16“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 7) = ActiveSheet.Range(„E25“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 8) = ActiveSheet.Range(„E24“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 9) = ActiveSheet.Range(„G7“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 10) = ActiveSheet.Range(„G16“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 11) = ActiveSheet.Range(„I16“).Value

Loletzte = IIf(IsEmpty(Worksheets(„Übersicht“).Range(„A65536“)), Worksheets(„Übersicht“).Range(„A65536“).End(xlUp).Row + 1, 65536)
Worksheets(„Übersicht“).Cells(Loletzte, 1) = ActiveSheet.Range(„A17“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 2) = ActiveSheet.Range(„B17“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 4) = ActiveSheet.Range(„E17“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 5) = ActiveSheet.Range(„D5“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 6) = ActiveSheet.Range(„H17“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 7) = ActiveSheet.Range(„E25“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 8) = ActiveSheet.Range(„E24“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 9) = ActiveSheet.Range(„G7“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 10) = ActiveSheet.Range(„G17“).Value
Worksheets(„Übersicht“).Cells(Loletzte, 11) = ActiveSheet.Range(„I17“).Value

MsgBox " Daten erfolgreich übernommen ", vbInformation, " Sicherung in Worksheet Übersicht "

End Sub

Es funktioniert auch alles, wobei die beiden letzten blöcke (eigentlich 8 an der zahl) nur dann eingeleitet werden dürfen, wenn in den Zellen, die auf x17 (bzw. auf x16) enden wirklich etwas eingetragen wurde. Die eintragungen laufen systematisch ab, d.h. in den x15er zellen ist immer etwas eingetragen , aber von x16-x22 nicht. jedoch ist es nicht üblich (das passiert auch nicht so), dass in den x15er und z.b. in den x17er etwas eingetragen ist und die x16er somit übersprungen wurde. Also ich bräuchte eine art prüfung vor jedem „block“, ob in den besagten zellen eine eintragung ist oder nicht. wenn nicht sollten die restlichen blöcke übersprungen werden und nur z.b. der erte übertragen werden.

hoffe ich habe das einigermaßen verständlich schildern können.
wäre super wenn mir jemand einen tipp geben könnte.

ich bin wirklich kein experte . habe den code mehr oder weniger zusammengeschustert. ist bestimmt nicht die eleganteste lösung, jedoch als laie, also für mich verständlich.

mfg

chris

Chris_Haas · 15. April 2008 um 18:42

hat sich erledigt. habe eine lösung gefunden.

trotzdem danke!

Reinhard_fb8cb7 · 15. April 2008 um 18:43

Es funktioniert auch alles, wobei die beiden letzten blöcke
(eigentlich 8 an der zahl) nur dann eingeleitet werden dürfen,
wenn in den Zellen, die auf x17 (bzw. auf x16) enden wirklich
etwas eingetragen wurde. Die eintragungen laufen systematisch
ab, d.h. in den x15er zellen ist immer etwas eingetragen ,
aber von x16-x22 nicht. jedoch ist es nicht üblich (das

Hi Christian,

probiers mal so:

Option Explicit
'
Private Sub CommandButton5\_Click()
Dim lngLetzte As Long, wksQ As Worksheet, wksZ As Worksheet 'Q=Quelle, Z=Ziel
Dim Zelle, Off As Byte, N As Byte, NN As Byte, OffS
Zelle = Array("A15", "B15", "E15", "D5", "H15", "E25", "E24", "G7", "G15", "I15")
OffS = Array(1, 1, 1, 0, 1, 0, 0, 0, 1, 1)
Set wksQ = ActiveSheet
Set wksZ = Worksheets("Übersicht")
On Error GoTo Fehler
With wksQ
 lngLetzte = wksZ.Range("A" & Rows.Count).End(xlUp).Row
 If lngLetzte = Rows.Count And wksZ.Range("A" & lngLetzte) "" Then Err.Raise vbObjectError + 1
 For N = 0 To 7
 If N 0 And .Range(Zelle(N)).Offset(0, OffS(0) \* N) = "" Then Exit For
 lngLetzte = lngLetzte + 1
 If lngLetzte = Rows.Count + 1 Then Err.Raise vbObjectError + 1
 For NN = 0 To 9
 If NN = 2 Then NN = NN + 1
 wksZ.Cells(lngLetzte, 1) = .Range(Zelle(N)).Offset(0, OffS(NN) \* N)
 Next NN
 Next N
End With
MsgBox " Daten erfolgreich übernommen ", vbInformation, " Sicherung in Worksheet Übersicht "
Exit Sub
Fehler:
 If Err.Number = vbObjectError + 1 Then
 MsgBox "Blatt voll"
 Else
 MsgBox "ging was Unbekanntes schief"
 End If
End Sub

Gruß
Reinhard