• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Copying Data from Multiple Worksheets based on Common Values

sharkey

sharkey

New Member
Good morning all,

I think I have the meat and potatoes for this from my extensive Google research, just need a little help combining what I have. Currently I have two macros that look at two separate worksheets and parse them into separate files based off of common values. My first macro does the "account summary" tab (has data in columns A-R), and then my second macro does the "account details" tab (has data in columns A-H). My end goal here would for the macro to do the actions of both of these macros, but save the two worksheets in one common file instead of two separate files. Any help on this would be greatly appreciated! My current macros are pasted below...

Thanks in advance!
Sharkey

Option Explicit

Sub ParseItemsAcctSumm()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

Set ws = Sheets("Account Summary")

SvPath = "C:\Users\jonathan.sharkey\Desktop\Test_Folder\Account_Summary\"

vTitles = "A1:R1"

vCol = 1

LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

Application.ScreenUpdating = False

ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

ws.Range("EE:EE").Clear

ws.Range(vTitles).AutoFilter

For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & " Account Summary" & Format(Date, " MM-DD-YY"), xlOpenXMLWorkbook
ActiveWorkbook.Close False

ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm

End Sub


Sub ParseItemsAcctDetails()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

Set ws = Sheets("Account Details")

SvPath = "C:\Users\jonathan.sharkey\Desktop\Test_Folder\Account_Details\"

vTitles = "A1:H1"

vCol = 1

LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

Application.ScreenUpdating = False

ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

ws.Range("EE:EE").Clear

ws.Range(vTitles).AutoFilter

For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & " Account Details" & Format(Date, " MM-DD-YY"), xlOpenXMLWorkbook
ActiveWorkbook.Close False

ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm

End Sub
 
Hi, sharkey!

As a new user you might want (I'd say should and must) read this:
http://chandoo.org/forum/forums/new-users-please-start-here.14/

And regarding your issue, consider uploading a sample file (including manual examples of desired output if applicable), it'd be very useful for those who read this and might be able to help you, relieving the contributor of having to build a test file, if necessary. Thank you.

Regards!

PS: When posting code, please use the feature of the 5th icon from the right of the reply area ribbon.
Code: 
here goes the code
 
Hi, sharkey!
I'll give a look at them right not. Just FYI, you can upload more than 1 file to the same post, and next time you could add the desired output worksheets as additional worksheets at the original file; later you can remove them, so as we have to deal with only 1 file.
Regards!
 
And the code...
Code: 
Option Explicit

Sub ParseItemsAcctSumm()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

Set ws = Sheets("Account Summary")

SvPath = "C:\Users\jonathan.sharkey\Desktop\Test_Folder\Account_Summary\"

vTitles = "A1:R1"

vCol = 1

LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

Application.ScreenUpdating = False

ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

ws.Range("EE:EE").Clear

ws.Range(vTitles).AutoFilter

For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & " Account Summary" & Format(Date, " MM-DD-YY"), xlOpenXMLWorkbook
ActiveWorkbook.Close False

ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm

End Sub


Sub ParseItemsAcctDetails()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

Set ws = Sheets("Account Details")

SvPath = "C:\Users\jonathan.sharkey\Desktop\Test_Folder\Account_Details\"

vTitles = "A1:H1"

vCol = 1

LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

Application.ScreenUpdating = False

ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

ws.Range("EE:EE").Clear

ws.Range(vTitles).AutoFilter

For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & " Account Details" & Format(Date, " MM-DD-YY"), xlOpenXMLWorkbook
ActiveWorkbook.Close False

ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm

End Sub
 
Hi, sharkey!

Give a look at this file:
https://dl.dropboxusercontent.com/u...s - Sample File (for sharkey at chandoo).xlsm

This is the code:
Code: 
Option Explicit

Sub AllInOne()
    ' constants
    Const ksWSNames = "@,Account Summary,Account Details"
    Const ksWSKeyColumns = "@#@ A#@ A"
    Const kiWSKeyColumnsMax = 3
    Const ksSeparatorItem = ","
    Const ksSeparatorDimension = "#"
    ' declarations
    Dim rngI As Range, rngW As Range, rngF As Range
    Dim sWSName() As String, sColumn() As String, sWork1() As String, sWork2() As String
    Dim sR1C1 As String, sFilter As String, iWCol As Integer, iFCol As Integer
    Dim I As Integer, J As Integer, K As Integer, A As String
    ' start
    '  application
    With Application
        .ScreenUpdating = False
    End With
    '  ranges
    sWSName = Split(ksWSNames, ksSeparatorItem)
    sWork1 = Split(ksWSKeyColumns, ksSeparatorDimension)
    ReDim sColumn(UBound(sWSName), kiWSKeyColumnsMax)
    For I = 1 To UBound(sWork1)
        sWork2() = Split(sWork1(I))
        For J = 1 To UBound(sWork2)
            If J <= kiWSKeyColumnsMax Then sColumn(I, J) = sWork2(J)
        Next J
    Next I
    ' process
    For I = 1 To UBound(sColumn, 1)
        ' worksheet
        Worksheets(sWSName(I)).Activate
        ' input range
        Set rngI = Cells(1, 1).CurrentRegion
        With rngI
            ' work column
            Set rngW = .Offset(1, .Columns.Count + 1).Resize(.Rows.Count - 1, 1)
            ' filter column
            Set rngF = rngW.Offset(0, 2)
            ' columns
            iWCol = rngW.Column
            iFCol = rngF.Column
            ' build formula
            sR1C1 = ""
            For J = 1 To UBound(sColumn)
                If sColumn(I, J) <> "" Then
                    If sR1C1 <> "" Then sR1C1 = sR1C1 & "&""_""&"
                    sR1C1 = sR1C1 & "RC[" & _
                        Range(sColumn(I, J) & "1").Column - .Columns.Count - 2 & _
                        "]"
                Else
                    Exit For
                End If
            Next J
        End With
        ' work range
        With rngW
            ' formula
            .FormulaR1C1 = "=" & sR1C1
            ' remove duplicates
            .Copy
            rngF.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End With
        ' filter range
        With rngF
            .RemoveDuplicates Columns:=1, Header:=xlNo
            ' filter
            For J = 1 To .Rows.Count
                If .Cells(J, 1).Value = "" Then Exit For
               
            Next J
        End With
        ' autofilter
        '  headers for autofilter
        rngW.Cells(0, 1).Value = "X"
        rngF.Cells(0, 1).Value = "Y"
        '  expand autofilter
        With Range(Columns(1), Columns(rngF.Column))
            .AutoFilter
            If Not ActiveSheet.AutoFilterMode Then .AutoFilter
        End With
        '  filter
        With rngF
            For J = 1 To .Rows.Count
                ' filter criteria
                sFilter = .Cells(J, 1).Value
                If sFilter = "" Then Exit For
                ' apply filter
                .AutoFilter rngI.Columns.Count + 2, .Cells(J, 1).Value
                ' copy filtered data
                Range(Rows(1), Rows(1).End(xlDown)).Copy
                ' target worksheet exists?
                For K = 1 To Worksheets.Count
                    If Worksheets(K).Name = sWSName(I) & "_" & sFilter Then Exit For
                Next K
                ' if not, add; if yes, clear
                If K > Worksheets.Count Then
                    Worksheets.Add , Worksheets(Worksheets.Count)
                    ActiveSheet.Name = sWSName(I) & "_" & sFilter
                Else
                    Worksheets(K).Activate
                    Worksheets(K).ClearContents
                    Worksheets(K).[A1].Select
                End If
                ' paste filtered data
                ActiveSheet.Paste
                ' remove applied filter
                Worksheets(sWSName(I)).ShowAllData
                ' copy format
                rngI.EntireColumn.Copy
                ' paste format
                Range(Columns(1), Columns(rngI.Columns.Count)).PasteSpecial _
                    Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, _
                    Transpose:=False
                [A1].Select
                Application.CutCopyMode = False
                ' clear work & filter helper
                Range(Columns(iWCol), Columns(iFCol)).ClearContents
                ' re-activate main WS
                Worksheets(sWSName(I)).Activate
            Next J
        End With
        '  clear work & filter ranges
        Range(Columns(iWCol), Columns(iFCol)).ClearContents
        [A1].Select
    Next I
    ' end
    '  application
    With Application
        .ScreenUpdating = True
    End With
    '  ranges
    Set rngF = Nothing
    Set rngW = Nothing
    Set rngI = Nothing
    '  beep
    Beep
End Sub

All the tricky&magic part is in the constants definition:
Code: 
    Const ksWSNames = "@,Account Summary,Account Details"
    Const ksWSKeyColumns = "@#@ A#@ A"
    Const kiWSKeyColumnsMax = 3
    Const ksSeparatorItem = ","
    Const ksSeparatorDimension = "#"

a) Constant ksWSNames contains the names of the source worksheets, comma separated (",").

b) Constant ksWSKeyColumns has this structure, numeral separated ("#"):
@ space 1st_key_col space 2nd_key_col space 3rd_key_col ...

c) Constant kiWSKeyColumnsMax specifies the max no. of key columns allowed (change as required).

(Both 2 first have a first "@" followed by the proper separator due to the option base 0 for arrays.)

Just advise if any issue.

Regards!
 
Good morning SirJB7, thanks for all of your work on this! My goal was actually to have the "desired output" files saved separately by the person's name, ideally in a designated folder. Let me know if you have any ideas, I'm going to sit and stare at this code to try and figure something out.

Thanks again.
 
Hi, sharkey!

Good afternoon. So I misread your requirements... well, nothing critical, a few tweaks et voilà!

Please download again the updated file from same previous DropBox link. This is the actual code:
Code: 
Option Explicit

Sub AllInOne()
    '
    ' constants
    '  output
    Const ksFolder = "Carlsberg, probably the best.. surely!"
    Const kbFolder = True ' set to False to use worksheets instead of workbooks
    Const ksExt = ".xlsx"
    Const ksSlash = "\" 'ksFolder starting with \ is full path, otherwise relative
    '  ranges
    Const ksWSNames = "@,Account Summary,Account Details"
    Const ksWSKeyColumns = "@#@ A#@ A"
    Const kiWSKeyColumnsMax = 3
    Const ksSeparatorItem = ","
    Const ksSeparatorDimension = "#"
    '
    ' declarations
    Dim rngI As Range, rngW As Range, rngF As Range
    Dim sWSName() As String, sColumn() As String, sWork1() As String, sWork2() As String
    Dim sR1C1 As String, sFilter As String, iWCol As Integer, iFCol As Integer
    Dim sFolder As String, sFilename As String, sName As String
    Dim I As Integer, J As Integer, K As Integer, A As String
    '
    ' start
    '  application
    With Application
        .ScreenUpdating = False
    End With
    '  ranges
    sWSName = Split(ksWSNames, ksSeparatorItem)
    sWork1 = Split(ksWSKeyColumns, ksSeparatorDimension)
    ReDim sColumn(UBound(sWSName), kiWSKeyColumnsMax)
    For I = 1 To UBound(sWork1)
        sWork2() = Split(sWork1(I))
        For J = 1 To UBound(sWork2)
            If J <= kiWSKeyColumnsMax Then sColumn(I, J) = sWork2(J)
        Next J
    Next I
    '  output
    If Left(ksFolder, 1) <> ksSlash Then _
        sFolder = ThisWorkbook.Path & Application.PathSeparator
    sFolder = sFolder & ksFolder & Application.PathSeparator
    '
    ' process
    For I = 1 To UBound(sColumn, 1)
        ' worksheet
        Worksheets(sWSName(I)).Activate
        ' input range
        Set rngI = Cells(1, 1).CurrentRegion
        With rngI
            ' work column
            Set rngW = .Offset(1, .Columns.Count + 1).Resize(.Rows.Count - 1, 1)
            ' filter column
            Set rngF = rngW.Offset(0, 2)
            ' columns
            iWCol = rngW.Column
            iFCol = rngF.Column
            ' build formula
            sR1C1 = ""
            For J = 1 To UBound(sColumn)
                If sColumn(I, J) <> "" Then
                    If sR1C1 <> "" Then sR1C1 = sR1C1 & "&""_""&"
                    sR1C1 = sR1C1 & "RC[" & _
                        Range(sColumn(I, J) & "1").Column - .Columns.Count - 2 & _
                        "]"
                Else
                    Exit For
                End If
            Next J
        End With
        ' work range
        With rngW
            ' formula
            .FormulaR1C1 = "=" & sR1C1
            ' remove duplicates
            .Copy
            rngF.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End With
        ' filter range
        With rngF
            .RemoveDuplicates Columns:=1, Header:=xlNo
            ' filter
            For J = 1 To .Rows.Count
                If .Cells(J, 1).Value = "" Then Exit For
               
            Next J
        End With
        ' autofilter
        '  headers for autofilter
        rngW.Cells(0, 1).Value = "X"
        rngF.Cells(0, 1).Value = "Y"
        '  expand autofilter
        With Range(Columns(1), Columns(rngF.Column))
            .AutoFilter
            If Not ActiveSheet.AutoFilterMode Then .AutoFilter
        End With
        '  filter
        With rngF
            For J = 1 To .Rows.Count
                ' filter criteria
                sFilter = .Cells(J, 1).Value
                If sFilter = "" Then Exit For
                ' name
                sName = sWSName(I) & "_" & sFilter
                ' apply filter
                .AutoFilter rngI.Columns.Count + 2, .Cells(J, 1).Value
                ' copy to ... folder/ws?
                If kbFolder Then
                    ' target workbook exists?
                    If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder
                    If Dir(sFolder & sName & ksExt) = "" Then
                        Workbooks.Add
                        ActiveWorkbook.SaveAs sFolder & sName & ksExt
                    Else
                        Workbooks.Open sFolder & sName & ksExt
                        Worksheets(1).Activate
                        Worksheets(1).Cells.ClearContents
                        Worksheets(1).[A1].Select
                    End If
                Else
                    ' target worksheet exists?
                    For K = 1 To Worksheets.Count
                        If Worksheets(K).Name = sName Then Exit For
                    Next K
                    ' if not, add; if yes, clear
                    If K > Worksheets.Count Then
                        Worksheets.Add , Worksheets(Worksheets.Count)
                        ActiveSheet.Name = sName
                    Else
                        Worksheets(K).Activate
                        Worksheets(K).Cells.ClearContents
                        Worksheets(K).[A1].Select
                    End If
                End If
                ' copy filtered data
                If kbFolder Then
                    ThisWorkbook.Activate
                    ThisWorkbook.Worksheets(sWSName(I)).Range(Rows(1), Rows(1).End(xlDown)).Copy
                    Workbooks(sName & ksExt).Activate
                Else
                    Range(Rows(1), Rows(1).End(xlDown)).Copy
                End If
                ' paste filtered data
                ActiveSheet.Paste
                ' remove applied filter
                ThisWorkbook.Worksheets(sWSName(I)).ShowAllData
                ' copy format
                rngI.EntireColumn.Copy
                ' paste format
                Range(Columns(1), Columns(rngI.Columns.Count)).PasteSpecial _
                    Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, _
                    Transpose:=False
                [A1].Select
                Application.CutCopyMode = False
                ' clear work & filter helper
                Range(Columns(iWCol), Columns(iFCol)).ClearContents
                ' if folder, save
                If kbFolder Then ActiveWorkbook.Close True
                ' re-activate main WB/WS
                ThisWorkbook.Activate
                Worksheets(sWSName(I)).Activate
            Next J
        End With
        '  clear work & filter ranges
        Range(Columns(iWCol), Columns(iFCol)).ClearContents
        [A1].Select
    Next I
    '
    ' end
    '  application
    With Application
        .ScreenUpdating = True
    End With
    '  ranges
    Set rngF = Nothing
    Set rngW = Nothing
    Set rngI = Nothing
    '  beep
    Beep
    '
End Sub

Added this to handle output folder:
Code: 
    Const ksFolder = "Carlsberg, probably the best.. surely!"
    Const kbFolder = True ' set to False to use worksheets instead of workbooks
    Const ksExt = ".xlsx"
    Const ksSlash = "\" 'ksFolder starting with \ is full path, otherwise relative
ksFolder: output folder, if enabled
kbFolder: true for using output folder, false for using worksheets
ksExt: default extension for new files

Try it and tell me if it's suitable for you.

Regards!
 
SirJB7,

Thanks again! I apologize, I don't think I explained well enough as to what I was trying to do. My end goal is to get separate workbooks by the person's name, each with two worksheets (Account Summary and Account Details), saved out in a designated folder.
 
Hi, sharkey!
I'm beginning to wonder how many six-packs of Carslberg will this cost you... Started from 1 pack, now by 5 and raising...
Regards!
 
@Marc L
Hi!
Not that much... just as Debraj(ex-Roy) new system...
http://chandoo.org/forum/threads/solve-this-text-retrieve-query.7510/#post-43248
or better new server...
http://chandoo.org/forum/threads/what-causes-this-to-happen.13931/#post-82370
... or datacenter...
I better upload the images since this guy appears to don't have much could storage space available, impossible to find an image!
https://dl.dropboxusercontent.com/u/60558749/My System (from Debraj Roy at chandoo.org).jpg
https://dl.dropboxusercontent.com/u/60558749/My Server room (from Debraj).gif
https://dl.dropboxusercontent.com/u/60558749/Debraj datacenter - IMG_5073-2.jpg

Regards!

@Debraj
Hi, (ex-Roy)!
Short of space, buddy? I can send you a couple of 256Mb and 128Mb just out-of-the-factory new-new pendrives...
Regards!

@sharkey
Hi!
I didn't miss about this. I hope to be able to post tomorrow.
Regards!
 
@SirJB7 Now servers and data centers are right up my alley! Those pictures do look much more enticing than what I'm used to though. Honestly hadn't heard of Carlsberg and I had to google it... (sorry)
 
@sharkey
Hi!
So you haven't ever heard about this divine nectar called Carlsberg? o_O
Then you deserve that I've forgotten absolutely about this thread! :p
Will give it a look tomorrow.
Regards!
 
@sharkey
Hi!
I didn't say it was impossible, just haven't found the time to modify it. Back from vacations if you're still interested I'd try to give another look at this.
Regards!
 
You must log in or register to reply here.
Back
Top