Macro doortrekken????

[dennis1724]

Kan iemand mij hiermee helpen?


Ik heb eeb macro gemaakt maar nu moet hij werken voor meerdre cellen

H9 moet werken t/m h48 en i9 t/m x9 moet worden i 9 t/m x48
rood moet het zelfde blijven.
moet ik dan voor ierdere cell opnieuw schrijven of is er een andere oplossing voor.

Sub vullen()


If Range("h9") = "1" Then

   [COLOR="Red"] Range("I5:X5").Copy[/COLOR]
    Range("I9:x9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If
     If Range("h9") = "2" Then

    [COLOR="red"]Range("I4:X4").Copy[/COLOR]
    Range("I9:x9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If
      If Range("h9") = "" Then
      Range("I9:x9").ClearContents
End If
End Sub

Groetjes

 

[Wigi]

Dennis

Je hebt hier op het forum nog 7 topics als niet-opgelost staan en waar je zelf niet de laatste poster bent. Dit maakt mij niet echt geneigd om op de deze vraag te antwoorden. Kan je ook code-tags gebruiken aub? Dat is het # icoon in de balk met iconen wanneer je een bericht schrijft. (ondertussen aangepast, waarvoor dank).

Wigi

 

[dennis1724]

Met een beetje puzzelen is het gelukt. Ik zal voortaan beter opletten om de vraag af te melden.

Option Explicit
Sub Kruisjes()
Dim c As Range
Dim d As Range

Dim ws As Worksheet



     For Each c In ThisWorkbook.ActiveSheet.Range("kruisje")
        If Cells(c.Row, "H") = "1" Then
           
                c.Value = "X"
            
   
 End If
 Next c
End Sub

Sub kruisjes2()
Dim c As Range
Dim d As Range

Dim ws As Worksheet



     For Each c In ThisWorkbook.ActiveSheet.Range("kruisje")
        If Cells(5, c.Column) = "" Then
           
                c.Value = ""
            
   
 End If
 Next c
End Sub



Sub Uitvoeren()
Call Kruisjes
Call kruisjes2
End Sub

 

[Wigi]

Sub vullen()
    For Each r In Range("H9:H48")
        Select Case r
            Case 0: r.Offset(, 1).Resize(, 16).ClearContents
            Case 1, 2: r.Offset(, 1).Resize(, 16).Value = Range("I" & 6 - r).Resize(, 16).Value
        End Select
    Next
End Sub

 

[dennis1724]

Hey Wigi,

Deze ziet er wel wat handiger uit ik ga er mee aan de slag.

Thanks