PDA

View Full Version : Insert Rows



Lande
11-20-2007, 10:08 AM
I would ultimately like column A to repeat the values 1-20. Right now, I have incomplete data. For example, my column A might look like:

1
2
3
8
9
16
17
1
6
1
2
3
5
6
9
10
11
20

Is there a macro to insert rows so that column A consistently has rows for each number 1-20? If this helps, there will always be a "1", but not necessarily an 20. So I will also want the last "1" to be the start of the final set of 1-20.

Thank you in advance for your help!

rory
11-20-2007, 11:02 AM
Try this:
Sub addRows()
Dim lngIndex As Long, lngRows As Long, lngCounter As Long
Application.screenupdating = False
lngRows = Cells(Rows.Count, "A").End(xlUp).Row
Do While lngRows > 0
For lngCounter = 20 To 1 Step -1
If Cells(lngRows, "A") <> lngCounter Then
Cells(lngRows + 1, "A").EntireRow.Insert
Cells(lngRows + 1, "A").Value = lngCounter
Else
lngRows = lngRows - 1
End If
Next lngCounter
Loop
application.screenupdating = true
End Sub

Bob Phillips
11-20-2007, 11:43 AM
Another way



Public Sub ProcessData()
Dim NumOnes As Long
Dim i As Long

NumOnes = Application.CountIf(Columns(1), 1)
Range("A1").Value = 1
Range("A2:A20").Formula = "=A1+1"
Range("A1:A20").Value = Range("A1:A20").Value
For i = 2 To NumOnes
Range("A1:A20").Copy Range("A" & 20 * (i - 1) + 1)
Next i
End Sub

Lande
11-20-2007, 11:56 AM
Rory- That code is either taking a very long time or freezing up excel (I'm assuming the former). Is this due to the looping procedure (I am not very comfortable with looping)?

Lande
11-21-2007, 01:09 PM
XLD - Your code does a good job of copying the appropriate nubmer of 1-20 sets, however, I need rows inserted where the 1-20 is missing, so that all of the data in the row stays together, including with its appropriate 1-20 value.

Basically the 1-20 value is a just a code and each row is a characteristic of a case. There will be 20 of these rows, or characteristics (labeled with the codes 1-20 as mentioned before) for each case. Currently, no cases have all 20 characteristics, but I would like to make a row for each of the 20 characteristics anyways.

Rory - After finally letting your code run over a long lunch, I came back to it erroring out when it reached the actual data because it started in row 65433 and when it got to the data, there was no longer space to insert rows. Is there a way to get it to start at the last actual data?

Thanks!

lucas
11-21-2007, 02:20 PM
Hi Lande,
I ran both of them on some sample data. Rory's will not work correctly if there are blanks in Column A. Other than that they both ran fine for me as I said on sample data. You might need to post what you are testing on.

Bob Phillips
11-21-2007, 02:23 PM
In that case, Rory's method is the way to go.

I have just tried it, and it woks fine for me.

otto
11-25-2007, 05:35 PM
Sub Insert_rows()
'
'
Dim cur_row As Long
cur_row = 1
'
Do While Range("A" & cur_row).Value <> ""
Do While Range("A" & cur_row).Value < 20

If Range("A" & cur_row).Value < 1 Then
MsgBox "value in A" & cur_row & " less than 1"
Exit Sub
End If

If Range("A" & cur_row).Value > 20 Then
MsgBox "value in A" & cur_row & " greater than 20"
Exit Sub
End If

If (Range("A" & cur_row).Value) = Range("A" & cur_row +
1).Value Then
MsgBox "duplicate numbers not allowed"
Exit Sub
End If

If Range("A" & cur_row).Value > Range("A" & cur_row + 1).Value Then
If Range("A" & cur_row + 1).Value <> 1 Then
MsgBox "next sequence must start with 1"
Exit Sub
End If
End If

If (Range("A" & cur_row).Value + 1) = Range("A" & cur_row + 1).Value Then
cur_row = cur_row + 1
End If

ElseIf Range("A" & cur_row).Value <> Range("A" & cur_row + 1).Value Then
Range("A" & cur_row + 1).Select
Selection.Insert Shift:=xlDown
Range("A" & cur_row + 1).Value = (Range("A" & cur_row).Value + 1)
Range("B" & cur_row + 1).Value = "generated"

cur_row = cur_row + 1

End If

Loop

cur_row = cur_row + 1


Loop

End Sub


here is the test result:

1

1223384generated95generated166generated177generated1869110generated211gener ated312generated513generated614generated915generated1016111720

18generated19generated20generated12generated3generated4generated5generated6 7generated8generated9generated10generated11generated12generated13generated1 4generated15generated16generated17generated18generated19generated20generate d1234generated567generated8generated9101112generated13generated14generated1 5generated16generated17generated18generated19generated20

otto
11-25-2007, 05:37 PM
sorry, the test results were colums A and B, they did not copy very well!

Lande
11-26-2007, 02:30 PM
My problem with Rory's solution was that I had a string in row 1 and was wanting to start in Row 2. Once I removed that first row, it worked perfectly!

As for otto's solution, I got a compile error at the "elseIf" line. However, I did get the other one to work, so didn't try figuring it out.

Thank you!!!

figment
11-26-2007, 02:57 PM
this looked like a fun problem so i submit my solution

Sub testing()
Dim curcount As Long, mult As Long, headrowlength As Byte
headrowlength = 1
mult = 0
curcount = 1
While Range("a" & mult * 20 + curcount + headrowlength) <> ""
If Range("a" & mult * 20 + curcount + headrowlength) > curcount Then
Range("a" & mult * 20 + curcount + headrowlength).EntireRow.Insert
ElseIf Range("a" & mult * 20 + curcount + headrowlength) < curcount Then
While curcount < 21
Range("a" & mult * 20 + curcount + headrowlength).EntireRow.Insert
curcount = curcount + 1
Wend
End If
curcount = curcount + 1
If curcount > 20 Then
mult = mult + 1
curcount = 1
End If
Wend
End Sub

otto
11-26-2007, 02:59 PM
Sorry, the 'end if' above the 'elseif' does not belong there. I must have fumble fingered the code after testing...which I should not have done.

Otto

Lande
12-04-2007, 02:54 PM
Figment - Your solution worked well. The only thing is that in the new row, I also need to new number (so 1-20 is listed)

figment
12-05-2007, 07:44 AM
Sub testing()
Dim curcount As Long, mult As Long, headrowlength As Byte
headrowlength = 1
mult = 0
curcount = 1
While Range("a" & mult * 20 + curcount + headrowlength) <> ""
If Range("a" & mult * 20 + curcount + headrowlength) > curcount Then
Range("a" & mult * 20 + curcount + headrowlength).EntireRow.Insert
Range("a" & mult * 20 + curcount + headrowlength)=curcount
ElseIf Range("a" & mult * 20 + curcount + headrowlength) < curcount Then
While curcount < 21
Range("a" & mult * 20 + curcount + headrowlength).EntireRow.Insert
Range("a" & mult * 20 + curcount + headrowlength)=curcount
curcount = curcount + 1
Wend
End If
curcount = curcount + 1
If curcount > 20 Then
mult = mult + 1
curcount = 1
End If
Wend
End Sub

mfegyver
12-20-2007, 07:47 PM
i have a similar problem ... but try using 2 vectors, one A(20) read your data, and other, starts from 1 to 20. then, for each number in A, B(A(i)) = 0. at this point, you will remain with B(i)<>0 for the missing values at A. (tell me if I understood your problem correctly...)
Option Explicit
Global n
Global B(), A()
Sub corretor()
Dim i, j, cl As Integer
'read vetor
n = 20
ReDim Preserve A(n), B(n)
cl = 1
Do While Cells(cl, 1) <> 0
cl = cl + 1
Loop
For i = 1 To cl
A(i) = Cells(i, 1)
B(i) = i
Next i
For i = cl To n
A(i) = i
B(i) = i
Next i
'END read vetor
' ***** ******
For i = 1 To n
B(A(i)) = 0
Next i
For i = 1 To n
A(B(i)) = 0
Cells(i, 40) = B(i)
Next i
For i = 1 To n
If A(i) = 0 Then
For j = 1 To n
If B(j) > 0 Then
A(i) = B(j)
B(j) = 0
GoTo 30
End If
Next j
30
End If
Next i
'***** *****
'complete vetor
For i = 1 To n
If A(i) <> 0 Then
For j = 1 To n
If B(j) <> 0 Then
A(i) = B(j)
End If
Next j
End If
Next i
'complete vetor

For i = 1 To n
Cells(i, 1) = A(i)
Cells(i, 40) = B(i)
Next i
'END vetor
End Sub


greetings
marcelo

mfegyver
12-20-2007, 08:13 PM
dear masters, my problem is to change the repetitive value for 1 to n in a vector (this case n=20) beggining with any sequency.
my code doesn?t 100% time... please I beg your help:Option Explicit
Global n
Global G(), H()
Sub corretor()
Dim i, j, falta As Integer
'read vetor
n = Cells(14, 2)
ReDim Preserve H(n), G(n)
For i = 1 To n
H(i) = Cells(14+i, 8)
G(i) = i
Next i
'END read vetor
' ***** ******
For i = 1 To n
G(H(i)) = 0
Next i
For i = 1 To n
H(G(i)) = 0
Cells(14 + i, 30) = G(i)
Next i
For i = 1 To n
If H(i) = 0 Then
For j = 1 To n
If G(j) > 0 Then
H(i) = G(j)
G(j) = 0
GoTo 30
End If
Next j
30
End If
Next i
'***** *****
'imprime vetor
For i = 1 To n
Cells(14 + i, 8) = H(i)
Cells(14 + i, 31) = G(i)
Next i
'FIM imprime vetor
End Sub
starting with
121551684719101118581316317209
it must be runned several times until it reach correctly a valid sequence!

figment
12-21-2007, 08:01 AM
give this a go
Sub corretor()
Dim i As Long, doagain As Boolean
n = Cells(14, 2)
ReDim Preserve H(n), G(n)
doagain = True
While doagain = True
doagain = False
For i = 1 To n
H(i) = Cells(14 + i, 8)
G(i) = i
Next

For i = 1 To n
If H(i) <= n Then G(H(i)) = 0
Next

For i = 1 To n
H(G(i)) = 0
Cells(14 + i, 30) = G(i)
Next

For i = 1 To n
If H(i) = 0 Then
H(i) = i
doagain = True
G(i) = 0
End If
Cells(14 + i, 8) = H(i)
Next
Wend
End Sub

mfegyver
12-21-2007, 09:59 AM
yehh... that?s one solution... many thanks:friends: .

now it?s working good. (slowly due to my not charming solution, but it works. the incoming instances will be for n=1000 - I?m screwed ...).
This was part of a bigger heuristic - called scatter search.

Now, When I try to run togheter with another function, states an error "out of stack space" . Do someone knows what it is? is this memory overflow? and what is the solution?
many thanks:banghead: :banghead: :banghead: :banghead: :banghead: :banghead: :banghead: :banghead: :banghead:
greeting
marcelo