Using User form to load workbook, extract and combine desired data into new workbook or worksheet

[SimpleUser]

Hi. I have this excel workbook xlsx with the 1st worksheet named as "Email Status" with data from column A to S as shown below.

I've previously manually extract the VM data by filtering and copying onto a new sheet for each ReferenceCode then using function

=CHAR(34)&"Name"&CHAR(34)&" IN ("&CHAR(34)&TEXTJOIN(CHAR(34)&","&CHAR(34),TRUE,Extract!C2:C14)&CHAR(34)&")"

to get results for those with "Exception" status. It's a bit troublesome to do it daily using this method.


Instead I'm thinking of using a user form. The idea is to load the excel workbook data and then by clicking the button it should export the desired data into a new workbook or worksheet.

I need help on the user form to load the workbook, extract and combine the VM data with only the status "Exception" according to each similar "ReferenceCode" into another workbook or worksheet to look like the following results as shown.

Is there any way that this can be done??

 

[mumps]

It is hard to work with a picture. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[SimpleUser]

Hi mumps. I've uploaded links to the file namely "ExtractData.xlsm" & "patchingdata.xlsx". The idea is using the user form in ExtractData.xlsm to load the excel file patchingdata.xlsx and by clicking a button, it should export the data into a new workbook or worksheet something like "RequiredOutcome.xlsx".

I need help to work on the user form in ExtractData.xlsm to load the workbook patchingdata.xlsx, extract and combine the VM data from "column C" with only the status "Exception" in "column O" and group them according to each similar "ReferenceCode" in "column A" then export the data into another workbook or worksheet to look like the results in "Required outcome.xlsx".

Is there any way to achieve this via vba?

 

[mumps]

Thanks for uploading the files. I'm somewhat busy today so I will have a closer look at your files later on and get back to you. I'm going to suggest that you not use a userform but instead have a popup which allows you to select the file from which you want to import the data. This would simply the process and give you the option to choose whatever file you want. Would this work for you?

 

[SimpleUser]

Thanks for uploading the files. I'm somewhat busy today so I will have a closer look at your files later on and get back to you. I'm going to suggest that you not use a userform but instead have a popup which allows you to select the file from which you want to import the data. This would simply the process and give you the option to choose whatever file you want. Would this work for you?

Yes. Thanks in advance for your help.

 

[mumps]

Try:

Sub FilterCopyData()
    Application.ScreenUpdating = False
    Dim dialog As FileDialog, filePath As String, srcRng As Range, dic As Object, desWS As Worksheet
    Dim lRow As Long, i As Long, arr() As Variant, x As Long, cnt As Long, fVisRow As Long, lVisRow
    Set desWS = ThisWorkbook.Sheets("RequiredOutcome")
    Set dialog = Application.FileDialog(msoFileDialogFilePicker)
    With dialog
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 0 Then
            filePath = .SelectedItems.Item(1)
            Workbooks.Open (filePath)
        End If
    End With
    lRow = Sheets("Email Status").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:A" & lRow).Resize(, 15).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
        End If
    Next i
    cnt = dic.Count
    dic.RemoveAll
    ReDim arr(1 To cnt, 1 To 3)
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
            With Sheets("Email Status")
                .Range("A1", .Range("S" & Rows.Count).End(xlUp)).AutoFilter Field:=1, Criteria1:=v(i, 1)
                .Range("A1", .Range("S" & Rows.Count).End(xlUp)).AutoFilter Field:=15, Criteria1:="Exception"
                If .[subtotal(103,A:A)] - 1 > 1 Then
                    fVisRow = .Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    lVisRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                    x = x + 1
                    arr(x, 1) = v(i, 1)
                    arr(x, 2) = v(i, 2)
                    arr(x, 3) = Join(Application.Transpose(.Range("C" & fVisRow & ":C" & lVisRow).Value), Chr(34) & "," & Chr(34))
                    arr(x, 3) = Chr(34) & "Name " & Chr(34) & " IN(" & Chr(34) & arr(x, 3) & Chr(34) & Chr(41)
                End If
            End With
        End If
    Next i
    Sheets("Email Status").Range("A1").AutoFilter
    With desWS
        .UsedRange.Offset(1).ClearContents
        .Range("A2").Resize(cnt, 3) = arr
        .Columns.AutoFit
    End With
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

 

[SimpleUser]

Try:

Sub FilterCopyData()
    Application.ScreenUpdating = False
    Dim dialog As FileDialog, filePath As String, srcRng As Range, dic As Object, desWS As Worksheet
    Dim lRow As Long, i As Long, arr() As Variant, x As Long, cnt As Long, fVisRow As Long, lVisRow
    Set desWS = ThisWorkbook.Sheets("RequiredOutcome")
    Set dialog = Application.FileDialog(msoFileDialogFilePicker)
    With dialog
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 0 Then
            filePath = .SelectedItems.Item(1)
            Workbooks.Open (filePath)
        End If
    End With
    lRow = Sheets("Email Status").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:A" & lRow).Resize(, 15).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
        End If
    Next i
    cnt = dic.Count
    dic.RemoveAll
    ReDim arr(1 To cnt, 1 To 3)
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
            With Sheets("Email Status")
                .Range("A1", .Range("S" & Rows.Count).End(xlUp)).AutoFilter Field:=1, Criteria1:=v(i, 1)
                .Range("A1", .Range("S" & Rows.Count).End(xlUp)).AutoFilter Field:=15, Criteria1:="Exception"
                If .[subtotal(103,A:A)] - 1 > 1 Then
                    fVisRow = .Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    lVisRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                    x = x + 1
                    arr(x, 1) = v(i, 1)
                    arr(x, 2) = v(i, 2)
                    arr(x, 3) = Join(Application.Transpose(.Range("C" & fVisRow & ":C" & lVisRow).Value), Chr(34) & "," & Chr(34))
                    arr(x, 3) = Chr(34) & "Name " & Chr(34) & " IN(" & Chr(34) & arr(x, 3) & Chr(34) & Chr(41)
                End If
            End With
        End If
    Next i
    Sheets("Email Status").Range("A1").AutoFilter
    With desWS
        .UsedRange.Offset(1).ClearContents
        .Range("A2").Resize(cnt, 3) = arr
        .Columns.AutoFit
    End With
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Hi Mumps, I've tried the code but the outcome worksheet became empty after loading the file. Please help.

Reference Code	APP NAME	QueryCodeForDB

 

[mumps]

This is what I get when I run the macro using the files you posted. Are you testing the macro using the files you posted or in different files?

Reference Code	APP NAME	QueryCodeForDB
AAB	Any Anti App (AAA)	"Name " IN("AAAAAAWEB01","AAAAAAWEB02")
ABCDEF	ABCDEF	"Name " IN("ABCDEFDRVSWEB21","ABCDEFDRVSWEB22")
IPXXR	Inc Pone	"Name " IN("IPXXRXVSDBS01","IPXXRXVSDBS02")
EPICS	Enchanted Phantom In Cloud Swift	"Name " IN("EPICSVRBIR01","EPICSVRBOE02","EPICSVRBOE03","EPICSVRCTS01","EPICSVRDHCP02","EPICSVRDIR02","EPICSVRECL01")

 

[SimpleUser]

This is what I get when I run the macro using the files you posted. Are you testing the macro using the files you posted or in different files?

Reference Code	APP NAME	QueryCodeForDB
AAB	Any Anti App (AAA)	"Name " IN("AAAAAAWEB01","AAAAAAWEB02")
ABCDEF	ABCDEF	"Name " IN("ABCDEFDRVSWEB21","ABCDEFDRVSWEB22")
IPXXR	Inc Pone	"Name " IN("IPXXRXVSDBS01","IPXXRXVSDBS02")
EPICS	Enchanted Phantom In Cloud Swift	"Name " IN("EPICSVRBIR01","EPICSVRBOE02","EPICSVRBOE03","EPICSVRCTS01","EPICSVRDHCP02","EPICSVRDIR02","EPICSVRECL01")

That's weird, I'm using the exact same files I've shared on my home pc and the resuare blank. Hmmm, I need to test on my work pc to find out. i'll update here once I test the code again. thanks for your help.

 

[SimpleUser]

Dear Mumps, I've tested again at work and it's working perfectly now. Thanks for all your help.