Build Array Macro for copying cells and pasting basis criteria

C

centaur87

New Member
Joined
May 9, 2016
Messages
13
Hi Excel Guru's..need a vba to resolve this.

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

[TABLE="class: grid, width: 20, align: center"]
<tbody>[TR]
[TD]ID[/TD]
[TD]ST[/TD]
[TD]NAME[/TD]
[TD]Asset[/TD]
[TD]Qty[/TD]
[TD]UOM[/TD]
[TD]Asset2[/TD]
[TD]Qty2[/TD]
[TD]UOM2[/TD]
[TD]Asset3[/TD]
[TD]Qty3[/TD]
[TD]UOM3[/TD]
[TD]Asset4[/TD]
[TD]Qty4[/TD]
[TD]UOM4[/TD]
[TD]Asset5[/TD]
[TD]Qty5[/TD]
[TD]UOM5[/TD]
[TD]Req type[/TD]
[TD]Justy[/TD]
[TD]Enclose[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]16-07-19[/TD]
[TD]xyz[/TD]
[TD]top[/TD]
[TD]5[/TD]
[TD]100[/TD]
[TD]rock[/TD]
[TD]8[/TD]
[TD]80[/TD]
[TD]soft[/TD]
[TD]10[/TD]
[TD]110[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Form[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]16-07-19[/TD]
[TD]abc[/TD]
[TD]rock-h[/TD]
[TD]9[/TD]
[TD]40[/TD]
[TD]soft[/TD]
[TD]6[/TD]
[TD]70[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Email[/TD]
[TD][/TD]
[TD]No[/TD]
[/TR]
</tbody>[/TABLE]


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.

[TABLE="class: grid, width: 50, align: center"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Sub ID[/TD]
[TD]ST[/TD]
[TD]NAME[/TD]
[TD]Asset[/TD]
[TD]Qty[/TD]
[TD]UOM[/TD]
[TD]Req type[/TD]
[TD]Justy[/TD]
[TD]Enclose[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]1.1[/TD]
[TD]16-07-19[/TD]
[TD]xyz[/TD]
[TD]top[/TD]
[TD]5[/TD]
[TD]100[/TD]
[TD]Form[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.2[/TD]
[TD]16-07-19[/TD]
[TD]xyz[/TD]
[TD]rock[/TD]
[TD]8[/TD]
[TD]80[/TD]
[TD]Form[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.3[/TD]
[TD]16-07-19[/TD]
[TD]xyz[/TD]
[TD]soft[/TD]
[TD]10[/TD]
[TD]110[/TD]
[TD]Form[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]2.1[/TD]
[TD]16-07-19[/TD]
[TD]abc[/TD]
[TD]rock-h[/TD]
[TD]9[/TD]
[TD]40[/TD]
[TD]Email[/TD]
[TD][/TD]
[TD]No[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]2.2[/TD]
[TD]16-07-19[/TD]
[TD]abc[/TD]
[TD]soft[/TD]
[TD]6[/TD]
[TD]70[/TD]
[TD]Email[/TD]
[TD][/TD]
[TD]No[/TD]
[/TR]
</tbody>[/TABLE]

Using VBA MACRO Button.

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

Regards
Centaur
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
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.

Code: 
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
 
Upvote 0
Hey you are awesome...
Actually i just realised i need a change in Table 2. Could you please check once more..

[TABLE="class: grid, width: 50, align: center"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Sub ID[/TD]
[TD]ST[/TD]
[TD]name[/TD]
[TD]Asset[/TD]
[TD]Qty[/TD]
[TD]UOM[/TD]
[TD]Req[/TD]
[TD]Justy[/TD]
[TD]Enclose[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD][/TD]
[TD="align: -webkit-right"]07-11-2019[/TD]
[TD]xyz[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Form[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.1[/TD]
[TD][/TD]
[TD][/TD]
[TD]Top[/TD]
[TD]5[/TD]
[TD]100[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.2[/TD]
[TD][/TD]
[TD][/TD]
[TD]Rock[/TD]
[TD]8[/TD]
[TD]80[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.3[/TD]
[TD][/TD]
[TD][/TD]
[TD]soft-hard[/TD]
[TD]10[/TD]
[TD]110[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD][/TD]
[TD]07-11-2019[/TD]
[TD]abc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Call[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]2.1[/TD]
[TD][/TD]
[TD][/TD]
[TD]Rock-hard[/TD]
[TD]9[/TD]
[TD]40[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]2.2[/TD]
[TD][/TD]
[TD][/TD]
[TD]soft[/TD]
[TD]6[/TD]
[TD]70[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Sorry again.



DanteAmor said:
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.

Code: 
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
Click to expand...
 
Upvote 0
centaur87 said:
Hey you are awesome...
Actually i just realised i need a change in Table 2. Could you please check once more..
Sorry again.
Click to expand...

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

Code: 
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
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top