Using cell value as column offset, then write to active cell

[rkkenyon]

This is another building block for formatting a large spread sheet I have to use, thanks in advance!

I need to use a cell value as a column offset, move right the corresponding offset, then write a "1" in the next 5 columns of that row.
Then repeat for the rest of the rows in my sheet.

Offset
1	1	1	1	1	1
2		1	1	1	1	1
3			1	1	1	1	1
4				1	1	1	1	1

<tbody>
</tbody>

 

[alansidman]

Try this:

Option Explicit


Sub offsetX()
    Dim i As Long, off As Long
    Dim lr As Long
    lr = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lr
        off = Range("A" & i)
        Range("A" & i).Offset(0, off) = 1
        Range("A" & i).Offset(0, off + 1) = 1
        Range("A" & i).Offset(0, off + 2) = 1
        Range("A" & i).Offset(0, off + 3) = 1
        Range("A" & i).Offset(0, off + 4) = 1
    Next i
End Sub

 

[JoeMo]

This assumes the header "Offset" is in A1.

Sub WriteOneX5WithOffset()
Dim Arr As Variant, i As Long
Arr = Array(1, 1, 1, 1, 1)
Application.ScreenUpdating = False
For i = 2 To Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count + 1
    Range("A" & i).Offset(0, Range("A" & i).Value).Resize(, UBound(Arr) + 1).Value = Arr
Next i
Range("A1").CurrentRegion.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

 

[rkkenyon]

Thank you so much! That worked great, and taught me a few things. Much appreciated

 

[rkkenyon]

Thanks JoeMo. Using that array made the macro a lot faster, especially when expanded out to 200 rows of data and writing 45 "1"s.

 

[JoeMo]

Thanks JoeMo. Using that array made the macro a lot faster, especially when expanded out to 200 rows of data and writing 45 "1"s.

You are welcome - thanks for the reply.

 

[StephenCrump]

Another approach, which might be of interest:

Dim lNumberOnes As Long
Dim rng As Range

lNumberOnes = 5
Set rng = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)

With rng.Offset(, 1).Resize(, lNumberOnes + Application.Max(rng) - 1)
    .Formula = "=IF(AND(COLUMN()>$A2,COLUMN()<=$A2+" & lNumberOnes & "),1,"""")"
    .Value = .Value
End With

 

[Rick Rothstein]

This assumes the header "Offset" is in A1.

Sub WriteOneX5WithOffset()
Dim Arr As Variant, i As Long
Arr = Array(1, 1, 1, 1, 1)
Application.ScreenUpdating = False
For i = 2 To Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count + 1
    Range("A" & i).Offset(0, Range("A" & i).Value).Resize(, UBound(Arr) + 1).Value = Arr
Next i
Range("A1").CurrentRegion.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Because you used the Array function to create the Arr array, the +1 that I highlighted in red will only be correct for the default Option Base 0... if the user declares Option Base 1, that +1 will generate a sixth output cell containing the #N/A error. I have rewritten your code to declare the array as a one-based array for all Option Base settings. Note that I also changed your For..Loop to a For..Each..Loop as I think that simplifies the code somewhat.

Sub WriteOneX5WithOffset()
  Dim Cell As Range, Arr As Variant
  Arr = [{1,1,1,1,1}]
  Application.ScreenUpdating = False
  For Each Cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    Cell.Offset(, Cell.Value).Resize(, UBound(Arr)) = Arr
  Next
  Range("A1").CurrentRegion.EntireColumn.AutoFit
  Application.ScreenUpdating = True
End Sub

 

[Ken Cowen]

If you prefer a formula rather than a macro to fill in the data area, the following formula should work. Put it in B2 and copy it across the range you want to populate.


=IF(AND(COLUMNS($B$2:B2)-$A2>=0,COLUMNS($B$2:B2)-$A2<5),1,"")


I hope this helps.

Ken

 

[JoeMo]

Because you used the Array function to create the Arr array, the +1 that I highlighted in red will only be correct for the default Option Base 0... if the user declares Option Base 1, that +1 will generate a sixth output cell containing the #N/A error. I have rewritten your code to declare the array as a one-based array for all Option Base settings. Note that I also changed your For..Loop to a For..Each..Loop as I think that simplifies the code somewhat.

Sub WriteOneX5WithOffset()
  Dim Cell As Range, Arr As Variant
  Arr = [{1,1,1,1,1}]
  Application.ScreenUpdating = False
  For Each Cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    Cell.Offset(, Cell.Value).Resize(, UBound(Arr)) = Arr
  Next
  Range("A1").CurrentRegion.EntireColumn.AutoFit
  Application.ScreenUpdating = True
End Sub

Can't imagine why anyone would tack on Option Base 1 to such a simple bit of code, but I like your alternative to the Array function - thanks!