copy formula across while skipping columns

[Joshua]

I'm trying to write a macro that will:
1) select a range of cells within the same row - where the first cell
in the range contains a formula with a link to another cell
2)macro copies the formula from the first cell in the range and
pastes
it into the remaining cells in the selected range, while skipping a
user defined number of columns

before macro:
A B C D E F G
1 10
2
3 10 20 30 40

after macro:
A B C D E F G
1 10 20 30 40
2
3 10 20 30 40

the formula in A1 is =A3. I'd like the user to be able to 1) select
the rangeA1:G1 and 2)run
the macro so that after running C1 refers to B3, E1 refers to C3,
etc. I'd like
this to also work where the formula contains a combination of one or
more links and/or arithmetic operations. Would be awesome if this
could also work vice-a-versa.

Any ideas for how to solve this would be much appreciated!

 

[ProfessionalExcel.com]

Joshua,

This procedure should do what you're after (excep the vice versa). It'll ask
you to enter in the number of spacer cells, but you can hard code this or
pass it in if required.

Just select the range (single row) that you want the formulas spaced out
over, then run the procedure. It applies the same formula that's in the first
cell of the selected range.

Public Sub CopyFirstCellFormula()

Dim rngSelection As Range
Dim rngCell As Range
Dim intShiftCellAmount As Integer
Dim intCellCount As Integer
Dim intLastCell As Integer
Dim intLoop As Integer
Dim intShiftCount As Integer

Application.ScreenUpdating = False

Set rngSelection = Application.Selection
intShiftCellAmount = CInt(InputBox("Enter number of cells to skip."))

intCellCount = rngSelection.Rows(1).Cells.Count
With rngSelection.Rows(1)
'Copy formula to all cells
For Each rngCell In .Cells
.Cells(1, 1).Copy rngCell
Next

'If shift amount is 0, job done
If intShiftCellAmount > 0 Then

'Get last cell to contain a formula
intLastCell = 1
Do Until intLastCell > intCellCount
intLastCell = intLastCell + intShiftCellAmount + 1
intShiftCount = intShiftCount + 1
Loop
intLastCell = intLastCell - intShiftCellAmount - 1

'Shift formulas
For intLoop = intLastCell To 2 Step -(intShiftCellAmount + 1)
'Copy formula
.Cells(1, intLoop).Formula = .Cells(1, intLoop -
(intShiftCellAmount * intShiftCount) + intShiftCellAmount).Formula
'Clear cells
Range(.Cells(1, intLoop - (intShiftCellAmount *
intShiftCount) + intShiftCellAmount), .Cells(1, intLoop - 1)).ClearContents
intShiftCount = intShiftCount - 1
Next

'Clean up remainder cells
For intLoop = intLastCell + 1 To intCellCount
.Cells(1, intLoop).ClearContents
Next
End If
End With

Application.ScreenUpdating = True

End Sub


--
Please rate this post if it ansers your question.

Thanks,

Chris
www.ProfessionalExcel.com

 

[Joshua]

Joshua,

This procedure should do what you're after (excep the vice versa). It'll ask
you to enter in the number of spacer cells, but you can hard code this or
pass it in if required.

Just select the range (single row) that you want the formulas spaced out
over, then run the procedure. It applies the same formula that's in the first
cell of the selected range.

Public Sub CopyFirstCellFormula()

Dim rngSelection As Range
Dim rngCell As Range
Dim intShiftCellAmount As Integer
Dim intCellCount As Integer
Dim intLastCell As Integer
Dim intLoop As Integer
Dim intShiftCount As Integer

    Application.ScreenUpdating = False

    Set rngSelection = Application.Selection
    intShiftCellAmount = CInt(InputBox("Enter number of cells to skip."))

    intCellCount = rngSelection.Rows(1).Cells.Count
    With rngSelection.Rows(1)
        'Copy formula to all cells
        For Each rngCell In .Cells
            .Cells(1, 1).Copy rngCell
        Next

        'If shift amount is 0, job done
        If intShiftCellAmount > 0 Then

            'Get last cell to contain a formula
            intLastCell = 1
            Do Until intLastCell > intCellCount
                intLastCell = intLastCell + intShiftCellAmount + 1
                intShiftCount = intShiftCount + 1
            Loop
            intLastCell = intLastCell - intShiftCellAmount - 1

            'Shift formulas
            For intLoop = intLastCell To 2 Step -(intShiftCellAmount + 1)
                'Copy formula
                .Cells(1, intLoop).Formula = .Cells(1, intLoop -
(intShiftCellAmount * intShiftCount) + intShiftCellAmount).Formula
                'Clear cells
                Range(.Cells(1, intLoop - (intShiftCellAmount *
intShiftCount) + intShiftCellAmount), .Cells(1, intLoop - 1)).ClearContents
                intShiftCount = intShiftCount - 1
            Next

            'Clean up remainder cells
            For intLoop = intLastCell + 1 To intCellCount
                .Cells(1, intLoop).ClearContents
            Next
        End If
    End With

    Application.ScreenUpdating = True

End Sub

--
Please rate this post if it ansers your question.

Thanks,

Chriswww.ProfessionalExcel.com

Chris-

This is great - its exactly what I was trying to do! Thank you for
your help.

Is it rather difficult to make it do vice-verca or to do the same
thing for columns?

Thanks,

Joshua

 

[ProfessionalExcel.com]

Joshua,

What exactly would you want to happen in terms of 'vice-versa'?


-----
Thanks,

Chris

www.ProfessionalExcel.com