VBA Gennemløbe celleområde og flytte resultat til andet område

Spørgsmålet er en udløber af
http://www.eksperten.dk/spm/663336

Dim Gentaget As String
    For Each c In Range("B2:J10").Cells
    X = 0
    Y = 0
    Z = 0
 
            Xcol = c.Column
            Xrow = 12
            Ycol = 12
            Yrow = c.Row
            Zcol = 15
            If c.Column > 4 Then Zcol = 16
            If c.Column > 7 Then Zcol = 17
            Zrow = 2
            If c.Row > 4 Then Zrow = 3
            If c.Row > 7 Then Zrow = 4
           
            X = Cells(Xrow, Xcol).Value
            Y = Cells(Yrow, Ycol).Value
            Z = Cells(Zrow, Zcol).Value
           
            For I = 1 To 9
            If InStr(X, I) > 0 And InStr(Y, I) > 0 And InStr(Z, I) > 0 Then
            Gentaget = Gentaget & I
            End If
         
            Next
    Cells(c.Row, (c.Column) + 19) = Gentaget
  Next
End Sub

jeg kan ikke teste, da jeg ikke har værdier

Gentaget skulle lige nulstilles

Sub CheckCelle()
    Dim Gentaget As String
    For Each c In Range("B2:J10").Cells
    Gentaget = ""
    X = 0
    Y = 0
    Z = 0
 
            Xcol = c.Column
            Xrow = 12
            Ycol = 12
            Yrow = c.Row
            Zcol = 15
            If c.Column > 4 Then Zcol = 16
            If c.Column > 7 Then Zcol = 17
            Zrow = 2
            If c.Row > 4 Then Zrow = 3
            If c.Row > 7 Then Zrow = 4
           
            X = Cells(Xrow, Xcol).Value
            Y = Cells(Yrow, Ycol).Value
            Z = Cells(Zrow, Zcol).Value
           
            For I = 1 To 9
            If InStr(X, I) > 0 And InStr(Y, I) > 0 And InStr(Z, I) > 0 Then
            Gentaget = Gentaget & I
            End If
         
            Next
    Cells(c.Row, (c.Column) + 19) = Gentaget
  Next
End Sub

Sub CheckCelle()
    Dim rCell As Range
    Dim Gentaget As String
    X = 0
    Y = 0
    Z = 0
       
    For Each rCell In ActiveSheet.Range("B2:J10").Cells
        Gentaget = ""
       
        Xcol = rCell.Column
        Xrow = 12
       
        Ycol = 12
        Yrow = rCell.Row
       
        Zcol = 15
        If rCell.Column > 4 Then Zcol = 16
        If rCell.Column > 7 Then Zcol = 17
       
        Zrow = 2
        If rCell.Row > 4 Then Zrow = 3
        If rCell.Row > 7 Then Zrow = 4
       
        X = Cells(Xrow, Xcol).Value
        Y = Cells(Yrow, Ycol).Value
        Z = Cells(Zrow, Zcol).Value
       
        For I = 1 To 9
            If InStr(X, I) > 0 And InStr(Y, I) > 0 And InStr(Z, I) > 0 Then
                Gentaget = Gentaget & I
            End If
        Next I
       
        rCell.Offset(0, 19).Value = Gentaget
    Next rCell
End Sub

Jep, den er der.

Mangler dog lige et enkelt check.
Hvis cellen i området indeholder en værdi i forvejen skal "Gentaget" sættes til denne værdi og overføres til den anden matrix.
Derefter skal den hoppe videre til næste i løkken.

Hvis cellen i området indeholder en værdi i forvejen skal "Gentaget" sættes til denne værdi og overføres til den anden matrix.

Hvilken celle ?
den aktive celle ?

eller offset cellen?

iøvrigt til lykke med sportsjobbet

Fik selv løst den:

Sub CheckCelle()
    Dim Gentaget As String
    For Each c In Range("B2:J10").Cells
    Gentaget = ""
   
    X = 0
    Y = 0
    Z = 0
 
            Xcol = c.Column
            Xrow = 12
            Ycol = 12
            Yrow = c.Row
            Zcol = 15
            If c.Column > 4 Then Zcol = 16
            If c.Column > 7 Then Zcol = 17
            Zrow = 2
            If c.Row > 4 Then Zrow = 3
            If c.Row > 7 Then Zrow = 4
           
            X = Cells(Xrow, Xcol).Value
            Y = Cells(Yrow, Ycol).Value
            Z = Cells(Zrow, Zcol).Value
           
            For I = 1 To 9
            If InStr(X, I) > 0 And InStr(Y, I) > 0 And InStr(Z, I) > 0 Then
            Gentaget = Gentaget & I
            End If
         
            Next
   
    If c <> "" Then
    Gentaget = c
    End If
           
    Cells(c.Row, (c.Column) + 19) = Gentaget
  Next
End Sub

Mange tak for hjælpen.
Der er 60 mere på vej .....

et svar ;-))

hvad er det du laver, SODUKU ?

hvis det er det, vil jeg godt have en kopi

jan - det hedder    If c.Value <> "" Then  (og den hurtigste hedder  If Not c.Value = "" Then)

Hvordan er det lige jeg sætter baggrundsfarven i matrix 2 hvis udtrykket
If c <> "" Then
Gentaget = c
End If

er opfyldt.

If c <> "" Then
Gentaget = c
Cells(c.Row, (c.Column) + 19).interior.colorindex=2
End If

If c <> "" Then
          Gentaget = c
          c.Offset(0, 19).Interior .ColorIndex = 6
          Else
          c.Offset(0, 19).Interior.ColorIndex = xlNone
          End If

Tak Flemming. Min virkede nu fint med min primitiv-VBA :-)

Jep, det er SUDOKU - godt set kabbak :-)
Jeg har sat mig for at lægge alle de løsningsstrategier jeg kender ind i et regneark.
Forhåbentlig er det så nok til at kunne løse en hvilken som helst opgave.

jaja - det virker, men flot er det ikke *s*
Du er også velkommen til at smide din model forbi fvd@smartoffice.dk når den er færdig

Det vil jeg gøre, men jeg ved ikke, om den nogensinde bliver færdig.
Det er noget af et ambitiøst projekt :-) - men meget sjovt.

Hvis det ikke betragtes som snyd, kan der jo også hentes lidt inspiration her:

http://www.di-mgt.com.au/sudoku.html