Microsoft Excel

Herbers Excel/VBA-Archiv

Spalte kopieren, wenn Wert nicht 0

Betrifft: Spalte kopieren, wenn Wert nicht 0 von: Marco
Geschrieben am: 15.09.2020 18:49:19

Hallo,
Ich komme bei dem Problem leider nicht weiter.

ich würde per Makro gerne folgendes Problem lösen:
In Tabelle1 soll die Zeile 409 durchsucht werden, beginnend bei Spalte L. Falls in der jeweiligen Zelle nicht 0 steht, soll die gesamte Spalte (oder Zeile 1 bis 413) in das Sheet Tabelle2 kopiert werden, beginnend bei H.
Die Ausgangstabelle (Tabelle1) ist dabei dynamisch hinsichtlich Spaltenanzahl. Die Zeilenanzahl ist mit 413 immer gleich.

Runtergebrochen habe ich also viele Spalten mit Daten. Wenn in der angesprochenen jeweiligen Zelle nicht 0 steht, sollen alle diese Spalten kopiert werden.

Danke vorab für die Bemühungen
Marco

Betrifft: AW: Spalte kopieren, wenn Wert nicht 0
von: ralf_b
Geschrieben am: 15.09.2020 19:07:59

ungetestet!

dim rng as Range , i as long
for i = 1 to Range("L409:L" & cells(409,Columns.count).end(xltoleft).Column ).columns.count

if cells(409,i) <>0 or cells(409,i) <>"0" then
set rng= Union(rng, Range(cells(1,i+ 7),Cells(409,i+7))
end if
next

rng.copy Tabelle2.Range("h1")

Betrifft: AW: Spalte kopieren, wenn Wert nicht 0
von: Marco
Geschrieben am: 15.09.2020 19:37:20

Hi, danke.
Ein erster Test davon liefert für die Zeile einen Fehler:(ungültiger Prozeduraufruf oder Argument).
set rng= Union(rng, Range(cells(1,i+ 7),Cells(409,i+7))

Ich schau mir das mal genauer an

Betrifft: na dann update
von: ralf_b
Geschrieben am: 15.09.2020 19:56:16

For i = 1 To Range("L409:L" & Cells(409, Columns.Count).End(xlToLeft).Column).Columns.Count

If Cells(409, i + 11).value <> 0 Or Cells(409, i + 11).value <> "0" Then
If i = 1 Then
Set rng = Range(Cells(1, i + 11), Cells(409, i + 11))
Else
Set rng = Union(rng, Cells(Cells(1, i + 11), Cells(409, i + 11)))
End If

End If
Next

Betrifft: AW: na dann update
von: Marco
Geschrieben am: 16.09.2020 11:02:37

Hi,

jetzt läuft der Code zwar durch, es passiert aber nichts. Ich habe mal eine Beispieldatei angefügt.

https://www.herber.de/bbs/user/140261.xlsm

Betrifft: AW: na dann nächster versuch
von: ralf_b
Geschrieben am: 16.09.2020 15:24:43

die zeile passt du selbst an. bei Spalte 12 wird die erste zelle geprüft
beim nächsten mal wen du eine datei hochlädst, dann pack auch den code mit rein.
Sub test()
Dim ws As Worksheet
Set ws = Worksheets("Tabelle1")

Dim rng As Range, i As Long
For i = 12 To ws.Cells(403, Columns.Count).End(xlToLeft).Column

If (ws.Cells(403, i).Value <> 0 Or ws.Cells(403, i).Value <> "0") And ws.Cells(403, i).Value <>  _
"" Then
    If rng Is Nothing Then
        Set rng = ws.Range(ws.Cells(1, i), ws.Cells(413, i))
    Else
        Set rng = Union(rng, ws.Range(Cells(1, i), Cells(413, i)))
    End If
    
End If
Next

rng.Copy Worksheets("Tabelle2").Range("h1")

Set rng = Nothing: Set ws = Nothing
End Sub


Betrifft: AW: Spalte kopieren, wenn Wert nicht 0
von: GerdL
Geschrieben am: 15.09.2020 20:12:14

Moin,

probier mal.
Sub Unit()
    
    Dim R As Range, Ct As Long

    
    With Tabelle1
        
        Set R = .Range(.Cells(409, 12), .Cells(409, .Columns.Count).End(xlToLeft))
    
        Ct = WorksheetFunction.CountIf(R, 0)
        If Ct < R.Count Then
    
            If Ct > 0 Then
                Set R = R.RowDifferences(Comparison:=R.Find(0, , xlValues, xlWhole))
            End If
            Intersect(R.EntireColumn, .Range("$1:$413")).Copy Tabelle2.Cells(1, 8)
    
        End If
    
    End With
    
    Set R = Nothing


End Sub

Gruß Gerd

Betrifft: AW: Spalte kopieren, wenn Wert nicht 0
von: Marco
Geschrieben am: 16.09.2020 11:01:06

Hi Gerd,

danke für den Code, funktioniert aber leider nicht. Der Code läuft zwar durch aber er kopiert mir stur etwas anderes.

Vielleicht ist eine Beispieldatei hilfreich:
https://www.herber.de/bbs/user/140261.xlsm

Betrifft: AW: Spalte kopieren, wenn Wert nicht 0
von: GerdL
Geschrieben am: 16.09.2020 11:54:35

Moin Marco,

ja, der Code ist "stur", kopiert aber m.E. -Referenzzeile angepasst - genau nach deiner Beschreibung.

Gruß Gerd

Beiträge aus dem Excel-Forum zum Thema "Spalte kopieren, wenn Wert nicht 0"