Build Array Macro for copying cells and pasting basis criteria

[centaur87]

Hi Excel Guru's..need a vba to resolve this.

Below table is my Onedrive source Data Set residing in Sheet1 (Table 1 )

ID

ST

NAME

Asset

Qty

UOM

Asset2

Qty2

UOM2

Asset3

Qty3

UOM3

Asset4

Qty4

UOM4

Asset5

Qty5

UOM5

Req type

Justy

Enclose

1

16-07-19

xyz

top

5

100

rock

8

80

soft

10

110

Form

Yes

2

16-07-19

abc

rock-h

9

40

soft

6

70

Email

No

<tbody>
</tbody>

I want a vba to convert above data set into below format (Table 2) pasting in same book under sheet2, but only for new entries done in Table 1

Sub ID will be generated based on Asset column : if value exists in Asset2 or Asset3, a new row is generatd below under same ID. If Value is Null in Asset2 or Asset3 then the array moves to next ID item line.

ID	Sub ID	ST	NAME	Asset	Qty	UOM	Req type	Justy	Enclose
1	1.1	16-07-19	xyz	top	5	100	Form		Yes
	1.2	16-07-19	xyz	rock	8	80	Form		Yes
	1.3	16-07-19	xyz	soft	10	110	Form		Yes
2	2.1	16-07-19	abc	rock-h	9	40	Email		No
	2.2	16-07-19	abc	soft	6	70	Email		No

<tbody>
</tbody>

Using VBA MACRO Button.

I appreciate your time and efforts.
Please write if you find any difficulty to understand.

Regards
Centaur

 

[DanteAmor]

Try this

Change Sheet1 and Sheet2 by the names of your sheets.
I assume that the data starts in row 2 and the headers are in row 1.

Sub Build_Array()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, j As Long, k As Long, col As Long, n As Long
    
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    sh2.Rows("2:" & Rows.Count).ClearContents
    k = 2
    col = sh1.Cells(1, Columns.Count).End(xlToLeft).Column - 3
    For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
        n = 1
        sh2.Cells(k, "A").Value = c.Value
        For j = 4 To col Step 3
            If sh1.Cells(c.Row, j).Value <> "" Then
                sh2.Cells(k, "B").Value = c.Value & "." & n
                sh2.Cells(k, "C").Value = c.Offset(, 1).Value
                sh2.Cells(k, "D").Value = c.Offset(, 2).Value
                sh2.Cells(k, "E").Resize(1, 3).Value = sh1.Cells(c.Row, j).Resize(1, 3).Value
                sh2.Cells(k, "H").Resize(1, 3).Value = sh1.Cells(c.Row, col + 1).Resize(1, 3).Value
                n = n + 1
                k = k + 1
            End If
        Next
    Next
    MsgBox "End"
End Sub

 

[centaur87]

Hey you are awesome...
Actually i just realised i need a change in Table 2. Could you please check once more..

ID	Sub ID	ST	name	Asset	Qty	UOM	Req	Justy	Enclose
1		07-11-2019	xyz				Form		Yes
	1.1			Top	5	100
	1.2			Rock	8	80
	1.3			soft-hard	10	110
2		07-11-2019	abc				Call		Yes
	2.1			Rock-hard	9	40
	2.2			soft	6	70

<tbody>
</tbody>

Sorry again.

Try this

Change Sheet1 and Sheet2 by the names of your sheets.
I assume that the data starts in row 2 and the headers are in row 1.

Sub Build_Array()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, j As Long, k As Long, col As Long, n As Long
    
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    sh2.Rows("2:" & Rows.Count).ClearContents
    k = 2
    col = sh1.Cells(1, Columns.Count).End(xlToLeft).Column - 3
    For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
        n = 1
        sh2.Cells(k, "A").Value = c.Value
        For j = 4 To col Step 3
            If sh1.Cells(c.Row, j).Value <> "" Then
                sh2.Cells(k, "B").Value = c.Value & "." & n
                sh2.Cells(k, "C").Value = c.Offset(, 1).Value
                sh2.Cells(k, "D").Value = c.Offset(, 2).Value
                sh2.Cells(k, "E").Resize(1, 3).Value = sh1.Cells(c.Row, j).Resize(1, 3).Value
                sh2.Cells(k, "H").Resize(1, 3).Value = sh1.Cells(c.Row, col + 1).Resize(1, 3).Value
                n = n + 1
                k = k + 1
            End If
        Next
    Next
    MsgBox "End"
End Sub

 

[DanteAmor]

Hey you are awesome...
Actually i just realised i need a change in Table 2. Could you please check once more..
Sorry again.

You are leaving many spaces in your table, that will not help you in future processes, such as sorting, filtering or copying.
Ideally, it should be like this:

Sub [COLOR=#0000ff]Build_Array2[/COLOR]()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, j As Long, k As Long, col As Long, n As Long
    
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    sh2.Rows("2:" & Rows.Count).ClearContents
    k = 2
    col = sh1.Cells(1, Columns.Count).End(xlToLeft).Column - 3
    For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
        n = 1
        For j = 4 To col Step 3
            If sh1.Cells(c.Row, j).Value <> "" Then
                sh2.Cells(k, "A").Value = c.Value
                sh2.Cells(k, "B").Value = c.Value & "." & n
                sh2.Cells(k, "C").Value = c.Offset(, 1).Value
                sh2.Cells(k, "D").Value = c.Offset(, 2).Value
                sh2.Cells(k, "E").Resize(1, 3).Value = sh1.Cells(c.Row, j).Resize(1, 3).Value
                sh2.Cells(k, "H").Resize(1, 3).Value = sh1.Cells(c.Row, col + 1).Resize(1, 3).Value
                n = n + 1
                k = k + 1
            End If
        Next
    Next
    MsgBox "End"
End Sub

--------------
My intention is to give advice on how you should have your information. But I give you what you need.

Try this:

Sub [COLOR=#0000ff]Build_Array3[/COLOR]()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, j As Long, k As Long, col As Long, n As Long
    
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    sh2.Rows("2:" & Rows.Count).ClearContents
    k = 2
    col = sh1.Cells(1, Columns.Count).End(xlToLeft).Column - 3
    For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
        n = 1
        sh2.Cells(k, "A").Value = c.Value               'ID
        sh2.Cells(k, "C").Value = c.Offset(, 1).Value   'ST
        sh2.Cells(k, "D").Value = c.Offset(, 2).Value   'name
        sh2.Cells(k, "H").Resize(1, 3).Value = sh1.Cells(c.Row, col + 1).Resize(1, 3).Value
        k = k + 1
        For j = 4 To col Step 3
            If sh1.Cells(c.Row, j).Value <> "" Then
                sh2.Cells(k, "B").Value = c.Value & "." & n
                sh2.Cells(k, "E").Resize(1, 3).Value = sh1.Cells(c.Row, j).Resize(1, 3).Value
                n = n + 1
                k = k + 1
            End If
        Next
    Next
    MsgBox "End"
End Sub

 

[centaur87]

@Dante AMOR, I have taken your advice and designed as per the same. This was very helpful. I Thank-you sincerely.

Regards

 

[DanteAmor]

@Dante AMOR, I have taken your advice and designed as per the same. This was very helpful. I Thank-you sincerely.

Regards

I'm glad to help you. Thanks for the feedback.