Insert and propagate Rows - based on a format rule

N

nochain

Could someone kindly offer a solution/vbscript to copy and populate rows of
data (adjusting the text string in Column A as part of the process) as
illustrated below.

The top section is an example of the source data containing batch numbers
with associated data in adjacent columns
The batch numbers in Column A will always be in this format/length
The second part of the string in column A dictates the range of individual 2
digit suffixes that the batch number / row of data pertains to

Hopefully the intention can be seen in the illustration below

Batch Ref Test1 Test2 Test3 Test4
0001-0102 GB 7.05 7.49 0.23 0.48
0001-0304 GB 7.22 7.91 0.23 0.48
0002-0102 SA 6.87 7.57 0.23 0.48
0002-0304 SA 6.77 7.33 0.24 0.48
0003-0103 PJ 7.17 7.61 0.23 0.49
0003-0406 PJ 7.11 4.72 0.23 0.60
0004-0106 PG 13.50 5.00 0.30 0.70




required result

0001-01 GB 7.05 7.49 0.23 0.48
0001-02 GB 7.05 7.49 0.23 0.48
0001-03 GB 7.22 7.91 0.23 0.48
0001-04 GB 7.22 7.91 0.23 0.48
0002-01 SA 6.87 7.57 0.23 0.48
0002-02 SA 6.87 7.57 0.23 0.48
0002-03 SA 6.77 7.33 0.24 0.48
0002-04 SA 6.77 7.33 0.24 0.48
0003-01 PJ 7.17 7.61 0.23 0.49
0003-02 PJ 7.17 7.61 0.23 0.49
0003-03 PJ 7.17 7.61 0.23 0.49
0003-04 PJ 7.11 4.72 0.23 0.6
0003-05 PJ 7.11 4.72 0.23 0.6
0003-06 PJ 7.11 4.72 0.23 0.6
0004-01 PG 13.5 5 0.3 0.7
0004-02 PG 13.5 5 0.3 0.7
0004-03 PG 13.5 5 0.3 0.7
0004-04 PG 13.5 5 0.3 0.7
0004-05 PG 13.5 5 0.3 0.7
0004-06 PG 13.5 5 0.3 0.7


Thanks
 
J

joel

the code will move the data from sheet 1 to sheet 2

Dim Prefix As String
Dim Suffix As String

With Sheets("sheet2")
.Range("A1") = "Batch Ref"
.Range("B1") = "Test Name"
.Range("C1") = "Test 1"
.Range("D1") = "Test 2"
.Range("E1") = "Test 3"
.Range("F1") = "Test 4"
NewRow = 2
End With

With Sheets("Sheet1")
.Columns("$B:$E").NumberFormat = "0.00"
RowCount = 2
Do While .Range("A" & RowCount) <> ""

Data = .Range("A" & RowCount)
'remove any place where the are two spaces in a row
Do While InStr(Data, " ") > 0
Data = Replace(Data, " ", " ")
Loop

DataArray = Split(Data)
OldBatchNumber = .Range("A" & RowCount)
Prefix = Left(OldBatchNumber, InStr(OldBatchNumber, "-"))
Suffix = Mid(OldBatchNumber, InStr(OldBatchNumber, "-") + 1)
'remove strings after first space
Suffix = Left(Suffix, 4)
StartNum = Val(Left(Suffix, 2))
EndNum = Val(Right(Suffix, 2))

With Sheets("sheet2")
For BatchNum = StartNum To EndNum
NewBatchNum = Prefix & Format(BatchNum, "00")
.Range("A" & NewRow) = NewBatchNum
For Index = 1 To 5
.Cells(NewRow, Index + 1) = DataArray(Index)
Next Index
NewRow = NewRow + 1
Next BatchNum
End With
RowCount = RowCount + 1
Loop

End With


End Su
 
S

SteveW

Thank you very much for your post Joel


just a small problem in running this sub.......

get a runtime error 9 subscript out of range............breaks at code line
below


Cells(NewRow, Index + 1) = DataArray(Index)


and the data on sheet1 looks like this at that point

Batch Ref Test Name Test 1 Test 2 Test 3 Test 4
0001-01 GB 7.05 7.49 0.23 0.48
0001-0304 GB 7.22 7.91 0.23 0.48
0002-0102 SA 6.87 7.57 0.23 0.48
0002-0304 SA 6.77 7.33 0.24 0.48
0003-0102 PJ 7.17 7.61 0.23 0.49
0003-0304 PJ 7.11 4.72 0.23 0.60
0004-0106 PG 13.50 5.00 0.30 0.70
 
J

joel

For some reason there isn't 7 columns of data. the code uses the spli
method to seperate the columns around blanks. If ther is anothe
invisible character besides a space (like a tab) then the split functio
would only get 6 or less columns and will give this error. Tr
replacing the following line

from
For Index = 1 To 5


to

For Index = 1 To Ubound(DataArray)

The code will run but probably some lines of data will not loo
correct. Let me know which lines don't give correct results. I notice
when you posted the data that some lines had two spaces between column
instead of 1. I then had to add the following lines to get rid o
double spaces.

Do While InStr(Data, " ") > 0
Data = Replace(Data, " ", " ")
Loop

I just noticed the posted code got changed. Replace the 6 X's belo
with spaces. The lines above are missing some spaces


Data = Replace(Data, vbtab, "X") 'I added this line to handle ta
characters

Do While InStr(Data, "XX") > 0
Data = Replace(Data, "XX", "X")
Loop


these lines of code are suppose to leave only one space between eac
columns
 
S

SteveW

Sorry Joel
I think my initial post & paste caused confusion ......here is the source data again............... I only ever had 6 separate spreadsheet columns.
6 columns A - F below

I will try to interpret and use your last explanation - but will still value any final thoughts from you.


Batch Ref Test Name Test 1 Test 2 Test 3 Test 4
0001-0102 GB 7.05 7.49 0.23 0.48
0001-0304 GB 7.22 7.91 0.23 0.48
0002-0102 SA 6.87 7.57 0.23 0.48
0002-0304 SA 6.77 7.33 0.24 0.48
0003-0102 PJ 7.17 7.61 0.23 0.49
0003-0304 PJ 7.11 4.72 0.23 0.60
0004-0106 PG 13.50 5.00 0.30 0.70



steve
 
J

joel

I wrote the code to work with your 6 columns. I wrote 7 by mistake i
my last posting. I looked at the code and saw the FOR statement (1 t
5) and took the 5 and added two (the BatchNumber and the two letter ID
the to get seven. I forgot the two letter ID was included in the 5 an
should of only added 5 + 1 = 6. The changes I suggested should of fixe
the problem.

from
Do While InStr(Data, " ") > 0
Data = Replace(Data, " ", " ")
Loop

to
Data = Replace(Data, vbtab, "X") 'Add line if there tabs seperat
columns.

Do While InStr(Data, "XX") > 0
Data = Replace(Data, "XX", "X")
Loop


Where the X's are replaced with space
 
N

nochain

Joel, I hope you can bear with me.

The version of your code that seemed to run here was as below (having
followed your posts), but produced an anomalous result

Batch Ref Test Name Test 1 Test 2 Test 3 Test 4
0001-01 GB 1.10 1.20 1.30 1.40
0001-02 PJ 2.00 2.10 2.20 2.30
0001-02
0001-02
0001-02
0001-02
0001-02
0001-02
0001-02
0001-02
0001-02


the entry in cell A3 (to the left of PJ) was another Batch ref which I had
made 0002-0104.
The original entry in cell A2 was 0001-0102 (as below)
The extra data rows created in Column A numbered 51,000 before I broke the
code

Batch Ref Test Name Test 1 Test 2 Test 3 Test 4
0001-0102 GB 1.10 1.20 1.30 1.40
0002-0104 PJ 2.00 2.10 2.20 2.30


Batch Ref Test Name Test 1 Test 2 Test 3 Test 4
0001-01 GB 1.10 1.20 1.30 1.40
0001-02 GB 1.10 1.20 1.30 1.40
0002-01 PJ 2.00 2.10 2.20 2.30
0002-02 PJ 2.00 2.10 2.20 2.30
0002-03 PJ 2.00 2.10 2.20 2.30
0002-04 PJ 2.00 2.10 2.20 2.30



Sub Propagate_Rows()

Dim Prefix As String
Dim Suffix As String

With Sheets("sheet2")
Range("A1") = "Batch Ref"
Range("B1") = "Test Name"
Range("C1") = "Test 1"
Range("D1") = "Test 2"
Range("E1") = "Test 3"
Range("F1") = "Test 4"
NewRow = 2
End With

With Sheets("Sheet1")
Columns("$C:$F").NumberFormat = "0.00"
RowCount = 2
Do While .Range("A" & RowCount) <> ""

Data = .Range("A" & RowCount)
'remove any place where the are two spaces in a row
Data = Replace(Data, vbTab, " ") 'I added this line to handle tab
Characters
Do While InStr(Data, " ") > 0
Data = Replace(Data, " ", " ")
Loop

DataArray = Split(Data)
OldBatchNumber = .Range("A" & RowCount)
Prefix = Left(OldBatchNumber, InStr(OldBatchNumber, "-"))
Suffix = Mid(OldBatchNumber, InStr(OldBatchNumber, "-") + 1)
'remove strings after first space
Suffix = Left(Suffix, 4)
StartNum = Val(Left(Suffix, 2))
EndNum = Val(Right(Suffix, 2))

With Sheets("sheet2")
For BatchNum = StartNum To EndNum
NewBatchNum = Prefix & Format(BatchNum, "00")
Range("A" & NewRow) = NewBatchNum
For Index = 1 To UBound(DataArray)
Cells(NewRow, Index + 1) = DataArray(Index)
Next Index
NewRow = NewRow + 1
Next BatchNum
End With
RowCount = RowCount + 1
Loop

End With


End Sub
 
J

joel

I found a few minor problems with th code that sholdn't of effected th
results. I left out some periods which indicate to use the "WITH
property in the code. The only bad results would of been some dat
would of been written to the wrong sheet. It is possible these error
changed some of the cells in sheet 1. Check to make sure none of th
data in sheet 1 got changed.

Remeber in the code beow to change the lines like before replacing th
X's with spaces.

Data = Replace(Data, vbtab, "X") 'Add line if there tabs seperat
columns.

Do While InStr(Data, "XX") > 0
Data = Replace(Data, "XX", "X")
Loop


I also added a new macro FindProblem to help debug the problem if th
the fixes didn't change the results. The macro writes on sheet 3 th
data from shet 1 putting each character in a seperate column along wit
the ASCII equivalent number in parenthesis. I couldn't duplicate th
results you were getting. I also had problems because the posted dat
actually changes some of the spaces to other character
(white/invisible) that got weird result when I used the new macro.
expect some of your spaces may not be spaces and need to find out wha
other characters are in the data.

I don't know hwat website you are posting your request because ther
are a number of websites that share their p[ostings. You can upload yo
file at the following website

http://www.thecodecage.com/forumz/newreply.php?do=newreply&p=594393

When you reply to the posting their is a button called Manag
Attachments where you can upload a file.



Code
-------------------
Sub Propagate_Rows()

Dim Prefix As String
Dim Suffix As String

With Sheets("sheet2")
.Range("A1") = "Batch Ref"
.Range("B1") = "Test Name"
.Range("C1") = "Test 1"
.Range("D1") = "Test 2"
.Range("E1") = "Test 3"
.Range("F1") = "Test 4"
.Columns("$C:$F").NumberFormat = "0.00"
NewRow = 2
End With

With Sheets("Sheet1")
RowCount = 2
Do While .Range("A" & RowCount) <> ""

Data = .Range("A" & RowCount)

'I added this line to handle tab Characters
Data = Replace(Data, vbTab, " ")

'remove any place where the are two spaces in a row
Do While InStr(Data, " ") > 0
Data = Replace(Data, " ", " ")
Loop

DataArray = Split(Data)
OldBatchNumber = .Range("A" & RowCount)

'split batch number around the dash
Prefix = Left(OldBatchNumber, InStr(OldBatchNumber, "-"))
Suffix = Mid(OldBatchNumber, InStr(OldBatchNumber, "-") + 1)

'remove strings after first space in 2nd part of batch num
Suffix = Left(Suffix, 4)

StartNum = Val(Left(Suffix, 2))
EndNum = Val(Right(Suffix, 2))

With Sheets("sheet2")
For BatchNum = StartNum To EndNum
NewBatchNum = Prefix & Format(BatchNum, "00")
.Range("A" & NewRow) = NewBatchNum

For Index = 1 To UBound(DataArray)
.Cells(NewRow, Index + 1) = DataArray(Index)
Next Index

NewRow = NewRow + 1
Next BatchNum
End With

RowCount = RowCount + 1
Loop

End With

End Sub

Sub FindProblem()

With Sheets("sheet1")
RowCount = 2
Do While .Range("A" & RowCount) <> ""
Data = .Range("A" & RowCount)

With Sheets("sheet3")
For ColCount = 1 To Len(Data)
DebugData = Mid(Data, ColCount, 1) & _
"(" & Asc(Mid(Data, ColCount, 1)) & ")"

.Cells(RowCount, ColCount) = DebugData
Next ColCount

End With

RowCount = RowCount + 1
Loop
End With
End Sub
 
N

nochain

Thanks once again for your patience Joel

No data has been written to sheet2 at my end yet
Data in sheet1 has been changed, which is not anticipated
I have shown the result of that by saving a sheet with that name

I ran the FindProblem macro with the results contained in sheet3

Most of the problems I guess have been caused by me pasting excel data into
MS Outlook Newsgroup message body ??....and the resultant spacing issues
etc?
I have been posting via Outlook News to msnews server
I can't quite interpret your advice re changing X's to spaces and what to
watch for........but maybe that won't be at the crux of the final tweaking
required?

I really do appreciate your solution provided......... and think its almost
sussed using my data/xls workbook.
I will upload my spreadsheet named "Propagate.xlsm" to your weblink given

Cheers
Steve aka nochain



joel said:
I found a few minor problems with th code that sholdn't of effected the
results. I left out some periods which indicate to use the "WITH"
property in the code. The only bad results would of been some data
would of been written to the wrong sheet. It is possible these errors
changed some of the cells in sheet 1. Check to make sure none of the
data in sheet 1 got changed.

Remeber in the code beow to change the lines like before replacing the
X's with spaces.

Data = Replace(Data, vbtab, "X") 'Add line if there tabs seperate
columns.

Do While InStr(Data, "XX") > 0
Data = Replace(Data, "XX", "X")
Loop


I also added a new macro FindProblem to help debug the problem if the
the fixes didn't change the results. The macro writes on sheet 3 the
data from shet 1 putting each character in a seperate column along with
the ASCII equivalent number in parenthesis. I couldn't duplicate the
results you were getting. I also had problems because the posted data
actually changes some of the spaces to other characters
(white/invisible) that got weird result when I used the new macro. I
expect some of your spaces may not be spaces and need to find out what
other characters are in the data.

I don't know hwat website you are posting your request because there
are a number of websites that share their p[ostings. You can upload you
file at the following website

http://www.thecodecage.com/forumz/newreply.php?do=newreply&p=594393

When you reply to the posting their is a button called Manage
Attachments where you can upload a file.



Code:
--------------------
Sub Propagate_Rows()

Dim Prefix As String
Dim Suffix As String

With Sheets("sheet2")
.Range("A1") = "Batch Ref"
.Range("B1") = "Test Name"
.Range("C1") = "Test 1"
.Range("D1") = "Test 2"
.Range("E1") = "Test 3"
.Range("F1") = "Test 4"
.Columns("$C:$F").NumberFormat = "0.00"
NewRow = 2
End With

With Sheets("Sheet1")
RowCount = 2
Do While .Range("A" & RowCount) <> ""

Data = .Range("A" & RowCount)

'I added this line to handle tab Characters
Data = Replace(Data, vbTab, " ")

'remove any place where the are two spaces in a row
Do While InStr(Data, " ") > 0
Data = Replace(Data, " ", " ")
Loop

DataArray = Split(Data)
OldBatchNumber = .Range("A" & RowCount)

'split batch number around the dash
Prefix = Left(OldBatchNumber, InStr(OldBatchNumber, "-"))
Suffix = Mid(OldBatchNumber, InStr(OldBatchNumber, "-") + 1)

'remove strings after first space in 2nd part of batch num
Suffix = Left(Suffix, 4)

StartNum = Val(Left(Suffix, 2))
EndNum = Val(Right(Suffix, 2))

With Sheets("sheet2")
For BatchNum = StartNum To EndNum
NewBatchNum = Prefix & Format(BatchNum, "00")
.Range("A" & NewRow) = NewBatchNum

For Index = 1 To UBound(DataArray)
.Cells(NewRow, Index + 1) = DataArray(Index)
Next Index

NewRow = NewRow + 1
Next BatchNum
End With

RowCount = RowCount + 1
Loop

End With

End Sub

Sub FindProblem()

With Sheets("sheet1")
RowCount = 2
Do While .Range("A" & RowCount) <> ""
Data = .Range("A" & RowCount)

With Sheets("sheet3")
For ColCount = 1 To Len(Data)
DebugData = Mid(Data, ColCount, 1) & _
"(" & Asc(Mid(Data, ColCount, 1)) & ")"

.Cells(RowCount, ColCount) = DebugData
Next ColCount

End With

RowCount = RowCount + 1
Loop
End With
End Sub


--------------------


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:
http://www.thecodecage.com/forumz/showthread.php?t=164405

Microsoft Office Help
Click to expand...
 
S

SteveW

Joel

I have now had some success
Data has been written to sheet2 now after I copied your latest code into a
new module.

When I upload the file you will see though that the data in columns B-F did
not get copied/propagated.


Steve
 
Top