Zellwertanpassung
Frank
ich benötige mal Euren Rat und hoffe dass ich mich verständlich ausdrücke. Ich möchte Werte von einem Tabellenblatt (Quelle) in mein Zieltabellenblatt (Ziel) mittels Zellwertfestlegung übertragen.
Sieht folgendermaßen aus.
Im Tabellenmodul (Ziel) steht wenn in A1 die Werte 1 bis 2 ausgewählt wurden - dann MakroA oder MakroB ausführen.
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Address(0, 0) = "A1" Then
If .Value = "1" Then
Call MakroA
ElseIf .Value = "2" Then
Call MakroB
End If
End If
End With
End Sub
Im Modulblatt stehen nun die beiden Makros bezogen aber immer auf Zeile 1. Wie muss ich dass denn anstellen, wenn ich in A2 die selbe Auswahl vornehmen möchte und die Zieladresse demzufolge Zeile 2 wäre. Ich muss aber in 17 Zeilen die Abfrage starten - und dort humpelt der Hamster sonst würde ich einfach die beiden Makros nochmal kopieren und Z=1 mit Z=2 ersetzen.
Einfach gesagt - Wenn Zellwert in A2 eine 2 wäre dann bitte MakroB starten aber in Zeile 2 beginnen, wenn in A13 Zellwert eine 1 dann bitte MakroA ausführen aber in Zeile 13 beginnen usw.
https://www.herber.de/bbs/user/81389.xls
Vielleicht hat jemand einen tip.
Danke Gruß Frank
Sub MakroA()
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Z = 1 ' übertragen in Zieltabelle - Zeile 1
For i = 4 To 7 Step 1 ' Beginn in Zeile 4 zu suchen bis Zeile 7
Sheets("Quelle").Select ' Ausgangstabelle
Worksheets("Quelle").Range(Cells(i, 7), Cells(i, 11)).Copy Destination:=Worksheets("Ziel"). _
Cells(Z, 5) ' Kopiere Zellen von Spalte 7 bis 11 in Zieltabelle nach Zeile 1, Spalte5
Z = Z + 5 ' gehe 5 Zeilen nach unten von ersten Zielwert
Next i
Sheets("Ziel").Select
Range("A4").Select
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
End Sub
Sub MakroB()
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Z = 1 ' übertragen in Zieltabelle - Zeile 1
For i = 13 To 16 Step 1 ' Beginn in Zeile 13 zu suchen bis Zeile 16
Sheets("Quelle").Select ' Ausgangstabelle
Worksheets("Quelle").Range(Cells(i, 7), Cells(i, 11)).Copy Destination:=Worksheets("Ziel"). _
Cells(Z, 5) ' Kopiere Zellen von Spalte 7 bis 11
Z = Z + 5 ' gehe 5 Zeilen nach unten von ersten Zielwert
Next i
Sheets("Ziel").Select
Range("A4").Select
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
End Sub