VBA Help with data copy

Lulu65 · Oct 1, 2013

Hello everyone,
I have on a worksheet (named "Stock out BS") a table like this (table lenght is undefined):

Category ID Description Prize
"A BS" "123" "aaaaaa" "10"
"B BS" "124" "bbbbb" "20"
"A BS" "125" "cccccc" "8"
"A BS" "126" "ddddd" "9"
"C BS" "127" "eeeeee" "11"

Then I have on a worksheet (named "Stock out TA") another table like this (table lenght is undefined):

Category ID Description Prize
"A TA" "223" "aaaaaaz" "101"
"B TA" "224" "bbbbbz" "201"
"C TA" "225" "ccccccz" "81"

I need to copy (ID, Description and Price) in another worksheet (named "Scale") starting from cell A2 the list of element from the previous 2 tables having Category=Ax
starting from cell G2 the list of element from the previous 2 tables having Category=Bx
starting from cell M2 the list of element from the previous 2 tables having Category=Cx
Each list should be ordered by Price.

Resulting table
Category A (cell A2)
"A TA" "223" "aaaaaaz" "101"
"A BS" "123" "aaaaaa" "10"
"A BS" "126" "ddddd" "9"
"A BS" "125" "cccccc" "8"

Category B (cell G2)
"B TA" "224" "bbbbbz" "201"
"B BS" "124" "bbbbb" "20"

Category C (cell M2)
"C TA" "225" "ccccccz" "81"
"C BS" "127" "eeeeee" "11"

I'm new with VBA and I need to solve this item asap.
Hope someone can help me
Thanks a lot

Marc L · Oct 2, 2013

Hi,

you can learn VBA by using the Macro Recorder during the filter on a worksheet …

Smallman · Oct 2, 2013

Hi Lulu

Can you upload a small file with the data in the tables and what the data looks like after the process is complete. That would be helpful to all.

Thanks

Smallman

SirJB7 · Oct 2, 2013

Hi, Lulu65!

Give a look at the uploaded file. Let us start for the VBA code which follows:

Code:

Option Explicit
 
Sub Tabling()
    '
    ' constants
    '  worksheets & ranges
    Const ksWSInput = "@,Stock out BS,Stock out TA"
    Const ksDataInput = "@,BSTable,TATable"
    Const ksWSOutput = "@,Scale,Scale,Scale"
    Const ksDataOutput = "@,CatATable,CatBTable,CatCTable"
    Const ksSortKeys = "@,D,C,B"
    Const ksSortOrders = "@,-,+,+,+"
    '  texts
    '  format
    Const kiDataColumn = 1
    Const kiDataPosition = 1
    Const kiDataLength = 1
    Const ksDataFilters = "@,A,B,C"
    '  others
    Const ksComma = ","
    Const ksColon = ":"
    Const ksAsterisk = "*"
    Const ksOrders = "+-"
    '
    ' declarations
    Dim rngI(2) As Range, rngO(3) As Range
    Dim lIndexO(3) As Long
    Dim vWSI As Variant, vDataI As Variant, vWSO As Variant, vDataO As Variant
    Dim vSortKeys As Variant, vSortOrders As Variant, vDataFilters As Variant
    Dim I As Long, J As Long, K As Integer, L As Integer, A As String
    '
    ' start
    '  arrays
    vWSI = Split(ksWSInput, ksComma)
    vDataI = Split(ksDataInput, ksComma)
    vWSO = Split(ksWSOutput, ksComma)
    vDataO = Split(ksDataOutput, ksComma)
    '  ranges
    For I = 1 To UBound(vWSI)
        Set rngI(I) = Worksheets(vWSI(I)).Range(vDataI(I))
    Next I
    For I = 1 To UBound(vWSO)
        Set rngO(I) = Worksheets(vWSO(I)).Range(vDataO(I))
        With rngO(I)
            If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
        End With
    Next I
    '  application
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    '  keys
    vSortKeys = Split(ksSortKeys, ksComma)
    '  orders
    vSortOrders = Split(ksSortOrders, ksComma)
    '  filters
    vDataFilters = Split(ksDataFilters, ksComma)
    For I = 1 To UBound(vDataFilters)
        lIndexO(I) = 1
    Next I
    '
    ' process
    '  filter
    For I = 1 To UBound(vWSI)
        With rngI(I)
            For J = 1 To .Rows.Count
                A = Mid(.Cells(J, kiDataColumn).Value, kiDataPosition, kiDataLength)
                For K = 1 To UBound(vDataFilters)
                    If A Like (ksAsterisk & vDataFilters(K) & ksAsterisk) Then Exit For
                Next K
                If K <= UBound(vDataFilters) Then
                    lIndexO(K) = lIndexO(K) + 1
                    For L = 1 To .Columns.Count
                        rngO(K).Cells(lIndexO(K), L).Value = .Cells(J, L).Value
                    Next L
                End If
            Next J
        End With
    Next I
    '  sort, if not
    For I = 1 To UBound(vWSO)
        Worksheets(vWSO(I)).Activate
        With rngO(I)
            With .Parent.Sort
                With .SortFields
                    .Clear
                    For J = 1 To UBound(vSortKeys)
                        .Add Key:=rngO(I).Range(vSortKeys(J) & ksColon & vSortKeys(J)), _
                            SortOn:=xlSortOnValues, _
                            Order:=InStr(ksOrders, vSortOrders(J)), _
                            DataOption:=xlSortNormal
                    Next J
                End With
                rngO(I).Columns.EntireColumn.Cells.Select
                .SetRange rngO(I).Columns.EntireColumn.Cells
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        .Cells(1, 1).Select
        End With
    Next I
    '
    ' end
    '  application
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
Tabling_Exit:
    '  ranges
    For I = 1 To UBound(vWSO)
        Set rngO(I) = Nothing
    Next I
    For I = 1 To UBound(vWSI)
        Set rngI(I) = Nothing
    Next I
    Beep
    '
End Sub

It uses 5 dynamic named ranges: BSTable in 1st worksheet, TATable in 2nd, and CatATable, CatBTable and CatCTable in 3rd.
Their definitions are similar being the 2 1st:
=DESREF('<worksheet>'!$A$2;;;CONTARA('<worksheet>'!$A:$A)-1;CONTARA('<worksheet>'!$1:$1)) -----> in english: =OFFSET('<worksheet>'!$A$2,,,COUNTA('<worksheet>'!$A:$A)-1,COUNTA('<worksheet>'!$1:$1))
i.e., all the used range except titles; and the 3 last:
=DESREF(<worksheet>!$A$1;;;CONTARA(<worksheet>!$A:$A);4) -----> in english: =OFFSET(<worksheet>!$A$1,,,COUNTA(<worksheet>!$A:$A),4)
i.e., the 4 columns for each whole used rows except titles.

In the code you can customize worksheets, named ranges, sort columns, sort orders, filter column, filter position, filter length, filter values, and... not anymore, I hope that it'll be enough.

Ranges in code are defined in arrays (2 for input, 3 for output) and you can tweak it if necessary with a little changes (including a ",xxx" in each string definition) for example for using with 10 input and 20 output, or the required numbers: just make sure to tie the pair of constants ksWS<Input/Output> and ksData<Input/Output> with consistent values.

I don't know if I miss something, but just advise if any issue.

Regards!

Smallman · Oct 2, 2013

This puppy should do the same.

Code:

Option Explicit
Option Base 1
Sub Moveme()
Dim ws As Worksheet
Dim lr As Long
Dim ar As Variant
Dim arr As Variant
Dim i As Integer
Application.DisplayAlerts = False
 
ar = Array("A2", "G2", "M2", "D", "J", "P")
arr = Array("A", "B", "C", "A", "G", "M")
Set ws = Worksheets.Add
 
Sheets("Scale").[A2:P10000].ClearContents
lr = Sheets("Stock out BS").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Stock out BS").Range("A:D").Copy ws.[a1]
Sheets("Stock out TA").Range("A2:D" & lr).Copy ws.Range("A65536").End(xlUp)(2)
 
    For i = 1 To 3
        ws.[a1].AutoFilter 1, arr(i) & "*"
        ws.Range("A2", ws.Range("D65536").End(xlUp)).Copy Sheets("Scale").Range(ar(i))
        Sheets("Scale").Range(arr(i + 3) & "1", Sheets("Scale").Range(ar(i + 3) _
        & "65536").End(xlUp)).Sort Sheets("Scale").Range(ar(i + 3) & "2"), 2
    Next i
ws.Delete
 
End Sub

Lulu65 · Oct 2, 2013

SirJB7 said:

Hi, Lulu65!

Give a look at the uploaded file. Let us start for the VBA code which follows:

Code:

Option Explicit
 
Sub Tabling()
    '
    ' constants
    '  worksheets & ranges
    Const ksWSInput = "@,Stock out BS,Stock out TA"
    Const ksDataInput = "@,BSTable,TATable"
    Const ksWSOutput = "@,Scale,Scale,Scale"
    Const ksDataOutput = "@,CatATable,CatBTable,CatCTable"
    Const ksSortKeys = "@,D,C,B"
    Const ksSortOrders = "@,-,+,+,+"
    '  texts
    '  format
    Const kiDataColumn = 1
    Const kiDataPosition = 1
    Const kiDataLength = 1
    Const ksDataFilters = "@,A,B,C"
    '  others
    Const ksComma = ","
    Const ksColon = ":"
    Const ksAsterisk = "*"
    Const ksOrders = "+-"
    '
    ' declarations
    Dim rngI(2) As Range, rngO(3) As Range
    Dim lIndexO(3) As Long
    Dim vWSI As Variant, vDataI As Variant, vWSO As Variant, vDataO As Variant
    Dim vSortKeys As Variant, vSortOrders As Variant, vDataFilters As Variant
    Dim I As Long, J As Long, K As Integer, L As Integer, A As String
    '
    ' start
    '  arrays
    vWSI = Split(ksWSInput, ksComma)
    vDataI = Split(ksDataInput, ksComma)
    vWSO = Split(ksWSOutput, ksComma)
    vDataO = Split(ksDataOutput, ksComma)
    '  ranges
    For I = 1 To UBound(vWSI)
        Set rngI(I) = Worksheets(vWSI(I)).Range(vDataI(I))
    Next I
    For I = 1 To UBound(vWSO)
        Set rngO(I) = Worksheets(vWSO(I)).Range(vDataO(I))
        With rngO(I)
            If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
        End With
    Next I
    '  application
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    '  keys
    vSortKeys = Split(ksSortKeys, ksComma)
    '  orders
    vSortOrders = Split(ksSortOrders, ksComma)
    '  filters
    vDataFilters = Split(ksDataFilters, ksComma)
    For I = 1 To UBound(vDataFilters)
        lIndexO(I) = 1
    Next I
    '
    ' process
    '  filter
    For I = 1 To UBound(vWSI)
        With rngI(I)
            For J = 1 To .Rows.Count
                A = Mid(.Cells(J, kiDataColumn).Value, kiDataPosition, kiDataLength)
                For K = 1 To UBound(vDataFilters)
                    If A Like (ksAsterisk & vDataFilters(K) & ksAsterisk) Then Exit For
                Next K
                If K <= UBound(vDataFilters) Then
                    lIndexO(K) = lIndexO(K) + 1
                    For L = 1 To .Columns.Count
                        rngO(K).Cells(lIndexO(K), L).Value = .Cells(J, L).Value
                    Next L
                End If
            Next J
        End With
    Next I
    '  sort, if not
    For I = 1 To UBound(vWSO)
        Worksheets(vWSO(I)).Activate
        With rngO(I)
            With .Parent.Sort
                With .SortFields
                    .Clear
                    For J = 1 To UBound(vSortKeys)
                        .Add Key:=rngO(I).Range(vSortKeys(J) & ksColon & vSortKeys(J)), _
                            SortOn:=xlSortOnValues, _
                            Order:=InStr(ksOrders, vSortOrders(J)), _
                            DataOption:=xlSortNormal
                    Next J
                End With
                rngO(I).Columns.EntireColumn.Cells.Select
                .SetRange rngO(I).Columns.EntireColumn.Cells
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        .Cells(1, 1).Select
        End With
    Next I
    '
    ' end
    '  application
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
Tabling_Exit:
    '  ranges
    For I = 1 To UBound(vWSO)
        Set rngO(I) = Nothing
    Next I
    For I = 1 To UBound(vWSI)
        Set rngI(I) = Nothing
    Next I
    Beep
    '
End Sub

It uses 5 dynamic named ranges: BSTable in 1st worksheet, TATable in 2nd, and CatATable, CatBTable and CatCTable in 3rd.
Their definitions are similar being the 2 1st:
=DESREF('<worksheet>'!$A$2;;;CONTARA('<worksheet>'!$A:$A)-1;CONTARA('<worksheet>'!$1:$1)) -----> in english: =OFFSET('<worksheet>'!$A$2,,,COUNTA('<worksheet>'!$A:$A)-1,COUNTA('<worksheet>'!$1:$1))
i.e., all the used range except titles; and the 3 last:
=DESREF(<worksheet>!$A$1;;;CONTARA(<worksheet>!$A:$A);4) -----> in english: =OFFSET(<worksheet>!$A$1,,,COUNTA(<worksheet>!$A:$A),4)
i.e., the 4 columns for each whole used rows except titles.

In the code you can customize worksheets, named ranges, sort columns, sort orders, filter column, filter position, filter length, filter values, and... not anymore, I hope that it'll be enough.

Ranges in code are defined in arrays (2 for input, 3 for output) and you can tweak it if necessary with a little changes (including a ",xxx" in each string definition) for example for using with 10 input and 20 output, or the required numbers: just make sure to tie the pair of constants ksWS<Input/Output> and ksData<Input/Output> with consistent values.

I don't know if I miss something, but just advise if any issue.

Regards!

Wow, you are Great!
It seems what I need! Now I will try to understand the code and apply it to my complex file.
Many thanks, Luciana

SirJB7 · Oct 2, 2013

Hi, Lulu65!

Don't forget to add the dynamic range definitions in your actual workbook: 2 input worksheets with a range each, 1 output worksheet with 3 ranges. Or tweak it as required.

You can divide the code as this:
a) Constants
- file related
- filter related
- others
b) Declarations
c) Start
- initialize arrays
- define ranges
- application
- other arrays
d) Process
- filter: walk thru the input ranges and load the output ones
- sort: the output ranges
d) End
- application
- destroy ranges

Hope it helps.

Regards!

VBA Help with data copy

Lulu65

New Member

Marc L

Excel Ninja

Smallman

Excel Ninja

SirJB7

Excel Rōnin

Attachments

Smallman

Excel Ninja

Lulu65

New Member

SirJB7

Excel Rōnin