Makro Spaltenweise wiederholen

Liebe VBA-Experten,
was für euch ein Klacks ist, ist für mich eine echte Herausforderung.
In der Datei möchte ich etwas relativ simples durchführen.
https://www.herber.de/bbs/user/130133.xlsx
In der Spalte B sind Formeln hinterlegt. Diese Formeln sollen in Spalte C kopiert werden, wenn in C1 eine Zahl größer 0 steht. Danach sollen die Ergebnisse als feste Werte kopiert werden.
Ein winziges Makro konnte ich selbst erstellen und das tut auch schon fast alles was ich brauche.
Was mir fehlt ist, dass das Makro sich Spalte für Spalte wiederholt. Also angefangen mit Spalte C, dann D, dann E, dann F etc.
Nett wäre es, wenn ich angeben könnte bis zu welcher Spalte sich das Makro wiederholen soll.
Mein Makro sieht wie folgt aus:


Sub IfThenElse()
If Cells(1, 3).Value > 0 Then
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C1").Select
Application.CutCopyMode = False
End If
End Sub

Else fehlt absichtlich, weil wenn die Zeile 1 nicht größer 0 ist, dann soll nichts passieren bzw. das Makro soll einfach in die nächste Spalte gehen und dort wieder von vorne anfangen.
Die unterschiedlichen Schleifen in VBA habe ich mir bereits angeschaut aber ich bekomme es einfach nicht zum laufen.
Wie muss der Code aussehen?
Vielen Dank vorab

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim Z As Long Dim S As Long Z = Cells(2, 2).End(xlDown.Row) S = Cells(1, 2).End(xlToRight).Column Range(Cells(2, 2), Cells(2, Z)).Copy With Range(Cells(2, 3), Cells(Z, S)) .PasteSpecial xlPasteFormats .Formula = .Value End With End Sub

Public Sub aaa() Dim loZeile As Long, loSpalte As Long, i As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") loZeile = .Cells(.Rows.Count, 1).End(xlUp).Row loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column For i = 3 To loSpalte If IsNumeric(.Cells(1, i)) And .Cells(1, i).Value > 0 Then .Cells(2, 2).Copy .Range(.Cells(2, i), .Cells(loZeile, i)).PasteSpecial Paste:=xlPasteFormulas .Range(.Cells(2, i), .Cells(loZeile, i)).Value = _ .Range(.Cells(2, i), .Cells(loZeile, i)).Value End If Next i Application.CutCopyMode = False End With End Sub

@ Werner, Tausend Dank, dein Makro funktioniert. Ich habe damit etwas gespielt um das Makro zu verstehen und es ist genau das was ich suchte.
Beim Testlauf auf der großen Datei kommt es jedoch zu einer winzigen Herausforderung. Nach jeder kopie bzw. einfügen der Formeln in die Spalten kommt das Pop-up: hier gibt es schon Daten. Möchten Sie diese ersetzen ; Ja/Nein
wie kann man das Pop-up umgehen?
@ Daniel
Danke für den Denkanstoß. Ich beantworte zunächst deine Fragen:
a) in etwa 900 Zeilen und 6.000 Spalten (mehrere Dateien). Also 5.4 Mio Zellen.
Von den 6.000 Spalten erfüllen nur etwa 500 bis 2.000 Spalten die Bedingung größer 0.
b) Leider verstehe ich deine Frage nicht ganz. Das Suchkriterium des Sverweis ist variabel und in den 900 Zeilen zu finden. Also 900 unterschiedliche Suchkriterien. Die Suchmatrix hat gegenwärtig 600 Spalten und 200 Zeilen, jedoch stetig wachsend. Spalte ist Variabel und wird mittels einer Hilfszeile errechnet. Konnte ich mit diesen Infos deine Frage beantworten?
c) Die Formeln sind so geschrieben, dass sie problemlos nach rechts oder nach unten gezogen (kopiert) werden können. Der Zahlenwert in der ersten Zeile ist die Hilfszeile die mir die Spaltennummer in der Suchmatrix errechnet. Wenn die Hilfszeile kleiner 0, dann ist in der Suchmatrix die gesuchte Spalte nicht vorhanden. Folglich kann das Makro direkt in die nächste Spalte gehen und dort nach der Bedingung größer 0 suchen.

Public Sub aaa() Dim loZeile As Long, loSpalte As Long, i As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") loZeile = .Cells(.Rows.Count, 1).End(xlUp).Row loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column For i = 3 To loSpalte If IsNumeric(.Cells(1, i)) And .Cells(1, i).Value > 0 Then .Cells(2, 2).Copy Application.DisplayAlerts = False .Range(.Cells(2, i), .Cells(loZeile, i)).PasteSpecial Paste:=xlPasteFormulas .Range(.Cells(2, i), .Cells(loZeile, i)).Value = _ .Range(.Cells(2, i), .Cells(loZeile, i)).Value Application.DisplayAlerts = True End If Next i Application.CutCopyMode = False End With End Sub

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread