Code Erweitern

[Klaumann2001]

Hallo Liebe Forum Gemeinde

Ich bin neu hier im Forum und bräuchte ein wenig Hilfe

Ich habe mir aus dem Internet folgende VBA Code zusammen gebastelt

Code:

Sub KopierenUndEinfuegen()
  Dim rngQuelle As Range
  Dim rngZiel As Range

  'Quelle definieren
  Set rngQuelle = ThisWorkbook.Sheets("Lagerberechnung").Range("H4:H21")

  Cells(1, 1).Select

  'Ziel definieren
  Set rngZiel = ThisWorkbook.Sheets("Lagerberechnung").Range("I4")
  Set rngZiel = ThisWorkbook.Sheets("Lagerberechnung").Range("G4")

  'Daten kopieren und einfügen
  rngQuelle.Copy
  rngZiel.PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
   With Selection
        .Borders.LineStyle = xlLineStyleNone
    End With
    ActiveSheet.Range("A1").Select
   
End Sub

Dieser Code geht auch so wie gewünscht es fehlt mir aber eine ganz wichtige Sache in diese VBA Rutine wo ich leider noch keine Lösung für gefunden habe.

Ich bräuchte noch eine Überprüfungsrutine ob eine Zelle leer oder 0 ist sollte dieses der Fall sein soll die entsprechende Zellen nicht kopiert werden

Ich weiß das es mit hilfe von  If und Then Anweisung geht aber ich habe keine Ahnung wie ich es sinnvoll einsetzen kann

Für eure Hilfe wäre ich sehr Dankbar

Viele Grüße

Klaumann2001

[Gast 123]

Hallo

ich weiss nicht ob ich mit meiner Lösung richtig liege, vielleicht hilft sie dir weiter?
Es empfiehlt sich ThisWorkbook.Sheet("Lagerberechnung") in eine With Klammer zu setzen!

mfg Gast 123

Code:

Sub KopierenUndEinfuegen()
  Dim rngQuelle As Range
  Dim rngZiel As Range

  'Quelle definieren
With ThisWorkbook.Sheets("Lagerberechnung")
  Set rngQuelle = .Range("H4:H21")

  'Ziel definieren
  If .Range("I4") <> "" Then
      Set rngZiel = .Range("I4")
  ElseIf .Range("G4") <> "" Then
      Set rngZiel = .Range("G4")
  Else: Exit Sub
  End If
 
  'Daten kopieren und einfügen
  rngQuelle.Copy
  rngZiel.PasteSpecial xlPasteValues, Transpose:=False

   With Selection
        .Borders.LineStyle = xlLineStyleNone
    End With
    ActiveSheet.Range("A1").Select
End With
End Sub

[Egon12]

Hallo,

eine weitere Möglichkeit:

Code:

Sub KopierenUndEinfuegen()
    Dim arrQ()
    With Sheets("Lagerberechnung")
        arrQ = .Range("H4:H21").Value
        If .Range("I4") = 0 Or .Range("I4") = "" Then
            With .Range("I4")
                .Resize(UBound(arrQ), 1) = arrQ
                .Resize(UBound(arrQ), 1).Borders.LineStyle = xlLineStyleNone
            End With
        Else
            If .Range("G4") <> "" Then Exit Sub
            With .Range("G4")
                .Resize(UBound(arrQ), 1) = arrQ
                .Resize(UBound(arrQ), 1).Borders.LineStyle = xlLineStyleNone
            End With
        End If
    End With
End Sub

Es werden eh nur Values übertragen. Die ursprünglich selektierte Zelle A1 bleibt selektiert, so dass das Rumselektieren im Blatt entfällt.

Gruß Uwe

[BoskoBiati]

Hi,

eigentlich reicht doch das:

Code:

Sub KopierenUndEinfuegen2()
Dim loZe As Long
    With ThisWorkbook.Sheets("Lagerberechnung")
        .Range("H4:H21").Copy
        .Range("G4").PasteSpecial xlPasteValues
        For loZe = 4 To 21
            If .Cells(loZe, 7) = "" Or .Cells(loZe, 7) = 0 Then Cells(loZe, 7).Delete shift:=xlUp
        Next
    End With
End Sub

[Egon12]

na gut,

hier noch kompakter und ohne Schleife:

Code:

Sub test()
    Dim arrQ(), adr$
    With Sheets("Lagerberechnung")
        If .Range("I4") <> "" And .Range("G4") <> "" Then Exit Sub
        arrQ = .Range("H4:H21").Value
        adr = IIf(.Range("I4") = 0 Or .Range("I4") = "", "I4", "G4")
        .Range(adr).Resize(UBound(arrQ), 1) = arrQ
        .Range(adr).Resize(UBound(arrQ), 1).Borders.LineStyle = xlLineStyleNone
    End With
End Sub

Mal sehen wer noch eine kürzere/kompaktere Lösung hat, es gibt ja noch snb. 
Es ist jetzt natürlich Spielerei meinerseits in Ermangelung an inspirierenden Anfragen.

Gruß Uwe

[derHoepp]

Moin,

ich würde Leerzeilen über den Autofilter ausschließen:

Code:

With Me.Range("A1:A10")
        .AutoFilter Field:=1, Criteria1:="<>"
        .Copy
        Tabelle2.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
    End With

noch besser wäre es natürlich, schon in der Quelle zu verhindern, dass leere Zeilen auftauchen. Aber dazu ist über die Grundstruktur zu wenig bekannt.

Viele Grüße
derHöpp

[BoskoBiati]

Hi,

und was ist mit den Nullen?

[Egon12]

sorry, --> richtig <>0 bzw. gar nicht erforderlich.

Gruß Uwe

[Klaumann2001]

Hallo

Vielen vielen Lieben Dank Ihr habt mir sehr sehr weitergeholfen   

Herzliche Grüße

Klaumann2001