VBA - adding row if column has value

[mcc1323]

Hi all,

Currently copying from an external workbook to my working workbook & worksheet.

This is the external worksheet:

My code below splits my column with multiple contract numbers as planned, however I want to be able to go from this:

To this below, where there is data past column D, there is another row added and the data from A:C is replicated and the contract number moves to column D. In addition, all columns past Column D are to be cleared.

Basically, for Contract 40007304, a line gets added (B7 as per below), and the details for Columns A-C for line B6 has been replicated for it. Same goes for all multiple contract #s.
Another complication is that there can be up to 10 unique contract numbers for a customer account, so the goal is for it to be the same as the above.



Current copy-paste VBA is as per below:

Sub get_copyt()

Application.ScreenUpdating = False 

Dim App As New Excel.Application 
Dim wb As Workbook
Dim copy As Range
Dim filter_date As Date

Set wb = ThisWorkbook
Set ws = Sheets("SheetA")

ws.Range("B3:E10000").ClearContents

Set copy_wb = App.Workbooks.Open(Filename:="ABC.csv", UpdateLinks:=True, ReadOnly:=True)

Set sht = wb.Worksheets(1)
Set StartCell = Range("A1")

lastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
lastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column

copy_wb.Worksheets("Sheet1").Range("A2:D" & lastRow).Copy
                    
Sheets("SheetA").Range("B3").PasteSpecial Paste:=xlPasteValues
copy_wb.Application.CutCopyMode = False
copy_wb.Close SaveChanges:=False

With ws
    .Range("C3:C500").Cut Destination:=ws.Range("E3:E500")
    .Range("C3:C500").Delete Shift:=xlToLeft
    

Set myRng = ws.Range("D3:D" & lastRow)
    myRng.TextToColumns _
        Destination:=ws.Range("E3:K3"), _
        DataType:=xlDelimited, _
        Tab:=False, _
        Semicolon:=False, _
        Comma:=True, _
        Space:=False, _
        Other:=False

End Sub

Help would be much appreciated on how to append the new code line to the existing one as I'm a bit lost.

Thank you!

 

[bebo021999]

Try to attach a mini sheet via XL2BB. In order to test the output, helpers have to input data manually, but most of them (include me )do not want to do that

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

 

[mcc1323]

Try to attach a mini sheet via XL2BB. In order to test the output, helpers have to input data manually, but most of them (include me )do not want to do that

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

Sorry about that!

Book2
	A	B	C	D
1	Account Name	Account Number	Contract Number(s)	Product
2	Customer A	1234	40007304	A1
3	Customer B	5678	40007397	A1
4	Customer C	9123	40007781	A1
5	Customer D	4567	40007325	A1
6	Customer E	8912	40007650, 40007304	A1
7	Customer F	3456	40007781	A1
8	Customer G	7891	40007994	A1
9	Customer H	2345	40007821, 40007806	A1
10	Customer I	6789	40007687	A2
11	Customer J	1123	40006576, 40007386	A1
12	Customer K	4456	40007723	A1
13	Customer L	7789	40007154	A3
14	CustomerM	1223	40006632	A4
Sheet1

Data here. Thank you!

 

[bebo021999]

I am testing with separate sub. If it worked, try to combine it into your main code:

Sub splitContract()
Dim lr&, i&, k&, cell As Range, s, arr(1 To 65000, 1 To 4)
lr = Cells(Rows.Count, "C").End(xlUp).Row ' last row of column C
For Each cell In Range("C2:C" & lr)
    s = Split(cell, ",") ' split contract numbers, base on ","
    For i = 0 To UBound(s) ' loop through each contract number of each row
        k = k + 1
        arr(k, 1) = cell.Offset(0, -2).Value
        arr(k, 2) = cell.Offset(0, -1).Value
        arr(k, 3) = s(i)
        arr(k, 4) = cell.Offset(0, 1).Value
    Next
Next
Range("A2").Resize(k, 4).Value = arr
End Sub

 

[mcc1323]

I am testing with separate sub. If it worked, try to combine it into your main code:

Sub splitContract()
Dim lr&, i&, k&, cell As Range, s, arr(1 To 65000, 1 To 4)
lr = Cells(Rows.Count, "C").End(xlUp).Row ' last row of column C
For Each cell In Range("C2:C" & lr)
    s = Split(cell, ",") ' split contract numbers, base on ","
    For i = 0 To UBound(s) ' loop through each contract number of each row
        k = k + 1
        arr(k, 1) = cell.Offset(0, -2).Value
        arr(k, 2) = cell.Offset(0, -1).Value
        arr(k, 3) = s(i)
        arr(k, 4) = cell.Offset(0, 1).Value
    Next
Next
Range("A2").Resize(k, 4).Value = arr
End Sub

Worked it in with existing code and it ran as expected - thank you!