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
 
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
 
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
 
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