A shorter way to write this macro

[light]

I have this macro but it seems like there must be a shorter way to do this. I have to write it for "If Cells(X, 161).Value = 1,2,3,4,5,6,7,8,9,10". Note (in the example below) as the if value increases by 1 on the left, the cell values increase by 1 as well on the right.

Sub Moan()
finalrow = Cells(Rows.Count, 160).End(xlUp).Row
For X = 4 To finalrow
If Cells(X, 161).Value = 1 Then Cells(X, 162).Value = Cells(X, 6).Value
If Cells(X, 161).Value = 1 Then Cells(X, 163).Value = Cells(X, 17).Value
If Cells(X, 161).Value = 1 Then Cells(X, 164).Value = Cells(X, 50).Value

If Cells(X, 161).Value = 1 Then Cells(X, 165).Value = Cells(X, 61).Value
If Cells(X, 161).Value = 1 Then Cells(X, 166).Value = Cells(X, 72).Value
If Cells(X, 161).Value = 1 Then Cells(X, 167).Value = Cells(X, 83).Value

If Cells(X, 161).Value = 2 Then Cells(X, 162).Value = Cells(X, 7).Value
If Cells(X, 161).Value = 2 Then Cells(X, 163).Value = Cells(X, 18).Value
If Cells(X, 161).Value = 2 Then Cells(X, 164).Value = Cells(X, 51).Value

If Cells(X, 161).Value = 2 Then Cells(X, 165).Value = Cells(X, 62).Value
If Cells(X, 161).Value = 2 Then Cells(X, 166).Value = Cells(X, 73).Value
If Cells(X, 161).Value = 2 Then Cells(X, 167).Value = Cells(X, 84).Value


Next X
End Sub

[bsalv]

Sub Moan()
     finalrow = Cells(Rows.Count, 160).End(xlUp).Row
     For x = 4 To finalrow
          Select Case Cells(x, 161).Value
               Case 1, 2
                    i =  Cells(x, 161).Value - 1
                    Cells(x, 162).Resize(, 6).Value = Array(Cells(x, 6 + i).Value, , Cells(x, 17 + i).Value, Cells(x, 50 + i).Value, Cells(x, 61 + i).Value, Cells(x, 72 + i).Value, Cells(x, 83 + i).Value)
          End Select
     Next
End Sub

[light]

Thanks but your macro deletes all data in column 163 and changes values in column 168 which I did not mention has values in it but is not part of my macro.

[JohnTopley]

Try

Sub Moan()
finalrow = Cells(Rows.Count, 160).End(xlUp).Row
col = Array(6, 17, 50, 61, 72, 83)
 j = Cells(x, 161) - 1
For x = 4 To finalrow   
    For k = 0 To 5
        Cells(x, 162 + k).Value = Cells(x, col(k) + j).Value
    Next k
Next x
End Sub

[bsalv]

i repeat the macro from above, with a small modification for the "Case" because it's 1 to 10
Column 168 ? the macro writes from column 162 for 6 columns, so 162-167, so it modifies(change/delete?) column 163 but column 168, no !

Sub Moan()
     finalrow = Cells(Rows.Count, 160).End(xlUp).Row
     For x = 4 To finalrow
          Select Case Cells(x, 161).Value
               Case 1, 2,3,4,5,6,7,8,9,10
                    i =  Cells(x, 161).Value - 1
                    Cells(x, 162).Resize(, 6).Value = Array(Cells(x, 6 + i).Value, , Cells(x, 17 + i).Value, Cells(x, 50 + i).Value, Cells(x, 61 + i).Value, Cells(x, 72 + i).Value, Cells(x, 83 + i).Value)
          End Select
     Next
End Sub

Can you post a file with non-sensitive data ?

[light]

bsalv still does the same thing as mentioned above

JohnTopley Thanks but I'm getting an 1004 error trying to run your macro

[JohnTopley]

Sub Moan()
finalrow = Cells(Rows.Count, 160).End(xlUp).Row
col = Array(6, 17, 50, 61, 72, 83)
For x = 4 To finalrow
    j = Cells(x, 161) - 1
    For k = 0 To 5
        Cells(x, 162 + k).Value = Cells(x, col(k) + j).Value
    Next k
Next x
End Sub

!

[light]

Thank you very much JohnTopley. Works great.

[jolivanes]

End Sub
Not much different from John's.
John was a lot faster with his (I assume it is "his") suggestion.

Sub How_About_So()
Dim colArr, j As Long, c As Range
colArr = Array(6, 17, 50, 61, 72, 83)
    For Each c In Range("FE4:FE" & Cells(Rows.Count, 160).End(xlUp).Row)
        For j = 1 To 6
            c.Offset(, j).Value = Cells(c.Row, colArr(j - 1)).Value
        Next j
    Next c
End Sub