Build Array Macro for copying cells and pasting basis criteria
Results 1 to 6 of 6

Thread: Build Array Macro for copying cells and pasting basis criteria

  1. #1
    New Member
    Join Date
    May 2016
    Posts
    13
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Build Array Macro for copying cells and pasting basis criteria

    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


    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

    Using VBA MACRO Button.

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

    Regards
    Centaur

  2. #2
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,732
    Post Thanks / Like
    Mentioned
    65 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Build Array Macro for copying cells and pasting basis criteria

    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
    Regards Dante Amor

  3. #3
    New Member
    Join Date
    May 2016
    Posts
    13
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Build Array Macro for copying cells and pasting basis criteria

    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

    Sorry again.



    Quote Originally Posted by DanteAmor View Post
    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

  4. #4
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,732
    Post Thanks / Like
    Mentioned
    65 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Build Array Macro for copying cells and pasting basis criteria

    Quote Originally Posted by centaur87 View Post
    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:
    Code:
    Sub Build_Array2()
        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 Build_Array3()
        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
    Regards Dante Amor

  5. #5
    New Member
    Join Date
    May 2016
    Posts
    13
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Build Array Macro for copying cells and pasting basis criteria

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

    Regards

  6. #6
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,732
    Post Thanks / Like
    Mentioned
    65 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Build Array Macro for copying cells and pasting basis criteria

    Quote Originally Posted by centaur87 View Post
    @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.
    Regards Dante Amor

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •