VBA Loop Code

[D. Stacy]

I have three column of data and I would like to use VBA code to go loop thru
the rows of data and then write output to another worksheet.

Value Range Label
1400 175 Red
2400 112 Blue
9000 710 Green

The output table (range) would look something like


1400 Red
1401 Red
1402 Red
1403 Red
....
....
....
...
2400 Blue
2401 Blue
etc. etc.


Thanks in advance!

 

[Mike H]

Hi,

Try this. Change SrcSheet & DestSheet to the correct sheets

Sub sonic()
Dim x As Long
Dim SrcSheet As String
Dim DestSheet As String
SrcSheet = "Sheet1"
DestSheet = "Sheet2"
x = 2
LastRow = Sheets(SrcSheet).Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets(SrcSheet).Range("A2:A" & LastRow)
For Each c In MyRange
Sheets(DestSheet).Cells(x, 1) = c.Value
Sheets(DestSheet).Cells(x, 2) = c.Offset(, 2).Value
x = x + 1
Next
End Sub

Mike

 

[Rob van Gelder]

What happens when you get to 9000. Is this also printed, and do you keep going past 9000, 9001, 9002, etc? Where do you stop?

This code assumes 9000 is not printed:


Sub test()
Const cFirstRow = 2
Const cValueCol = 1, cColourCol = 3
Dim i As Long, lng As Long, lngLimit As Long, strColour As String
Dim rngDest As Range

Set rngDest = Sheet2.Cells(1, 1)

With Sheet1
i = cFirstRow
lng = .Cells(i, cValueCol)
Do
strColour = .Cells(i, cColourCol)
i = i + 1
lngLimit = .Cells(i, cValueCol)
If lngLimit = 0 Then Exit Do

Do
rngDest = lng
rngDest.Offset(0, 1) = strColour
Set rngDest = rngDest.Offset(1)
lng = lng + 1
Loop While lng < lngLimit
Loop
End With
End Sub


Cheers,
Rob

 

[Don Guillett]

Try this using autofill instead

Option Explicit
Sub fillinnumsSAS()
Dim ss As Worksheet
Dim ds As Worksheet
Dim slr As Long
Dim dlr As Long
Dim i As Long
Dim mc As Long
Set ss = sheets("Sheet20")
Set ds = sheets("Sheet21")
slr = ss.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
For i = 2 To slr
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row
mc = ss.Cells(i + 1, 1) - ss.Cells(i, 1)
With ds
.Cells(dlr, 1) = ss.Cells(i, 1)
.Cells(dlr, 2) = ss.Cells(i, 3)
.Range(.Cells(dlr, 1), .Cells(dlr, 2)).AutoFill _
Destination:=.Range(.Cells(dlr, 1), .Cells(dlr + mc, 2))
End With
Next i
End Sub

 

[D. Stacy]

I did not state my problem / desired solution clearly enough. The three
suggestions posted so far are not hitting the mark.

The goal is to assign the "label" value to a series of sequential "values"
beginning with the value in row 1 thru the value in row 1 plus the range
value. Thus the output should have listing that begins with 1400 and then at
1575 should beging the 2400 series and then at 2512 jump to 9000 stopping at
9710. All the while I need the Label values (Red, Blue, Green) to be
assigned to the series of incrementing numbers.

This code is what I was working with prior to my first post. It does
everything OK except that it does not output the correct values (it just
inserts the proper amount of rows)
Sub AddRows()
Dim Cell As Range
' 1st Cell with the range (i values)
Set Cell = Range("D1")
Do While Not IsEmpty(Cell)
If Cell > 0.9 Then
Range(Cell.Offset(1, 0), Cell.Offset(Cell.Value - 1,
0)).EntireRow.Insert
Range(Cell, Cell.Offset(Cell.Value - 1, 1)).EntireRow.FillDown
End If
Set Cell = Cell.Offset(Cell.Value, 0)
Loop
End Sub

 

[Don Guillett]

If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.

 

[Rob van Gelder]

Here you go...

Sub test()
Const cFirstRow = 2
Const cValueCol = 1, cRangeCol = 2, cColourCol = 3
Dim i As Long, lng As Long, lngLimit As Long, strColour As String
Dim rngDest As Range

Set rngDest = Sheet2.Cells(1, 1)

With Sheet1
For i = cFirstRow To .Cells(Rows.Count, cValueCol).End(xlUp).Row
lng = .Cells(i, cValueCol)
lngLimit = .Cells(i, cRangeCol)
strColour = .Cells(i, cColourCol)
For lng = .Cells(i, cValueCol) To .Cells(i, cValueCol) + .Cells(i, cRangeCol)
rngDest = lng
rngDest.Offset(0, 1) = strColour
Set rngDest = rngDest.Offset(1, 0)
Next
Next
End With
End Sub

Cheers,
Rob