VBA - Before After macro no 3

Hi

I have the excel file with again 2 sheets:
Before
Recap

I need to transfer single combination from Before sheet on column B, E, F.into sheet Recap in column BE, BF and BG.

Once transferred into sheet Recap, i need to sort by Vendor column BE.

How can I do this?

Sheet Before look's like:
Sheet-Before.jpg
Sheet Recap will look like this based on above sheet Before:
Sheet-Recap.jpg
This is what i have so far:
Dim lrow As Long
    Dim ws As Worksheet, ws1 As Worksheet
 
    Set ws = Sheets("Before")
    Set ws1 = Sheets("Recap")
    lrow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row
    lr = ws1.Cells(Cells.Rows.Count, "d").End(xlUp).Row

    If lr > 10 Then ws1.Range("BE2:BG" & lr).ClearContents

     ws.Range("B2:F" & lrow).Copy ws1.Range("BE3")
    lr = ws1.Cells(Cells.Rows.Count, "d").End(xlUp).Row

    ws1.Range("BE3:BF" & lr).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    
    Set oneRange = Range("BE3:BG75000")
    Set aCell = Range("BE3")
    oneRange.Sort Key1:=aCell, Order1:=xlAscending

Open in new window

FIND-MATCH-no-2.xlsm
LVL 11
Wilder1626Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Try recording a macro while you do it manually.
0
Wilder1626Author Commented:
If i do a recording macro, and use sheet2 to do all conversion, it would look something like below. But i don't like to use another sheet for that.

Sheets("Sheet2").Range("A1:G75000").ClearContents

Sheets("Before").Columns("B:F").Copy

Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Columns("B:C").Delete Shift:=xlToLeft
Range("D2").Select
ActiveCell.FormulaR1C1 = "=RC[-3]&RC[-2]&RC[-1]"
Range("D2").Select

Selection.AutoFill Destination:=Range("D2:D75000"), Type:=xlFillDefault
ActiveSheet.Range("$A$1:$D$75000").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
Header:=xlYes

Range("A1:C7500").Select
Selection.Copy

Sheets("Recap").Select
Range("BE2").Select
ActiveSheet.Paste
Range("BE2").Select

Open in new window

0
Martin LissOlder than dirtCommented:
I probably don't understand your need but why not use the sheet you want instead of Sheet2? If there is no current sheet you can se then you can create a sheet (or use Sheet2) and hide it.
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Wilder1626Author Commented:
I'm looking at the snapshot i provided and i see why it is a little confusing.

If you see in sheet Before, you may see multiple duplication based on columns B,E and F.

I want to sent in Sheet Recap One record of each only. No Duplication.

Sheet Before:
Sheet Before
Sheet Recap with one record of each:
Sheet Recap
0
Wilder1626Author Commented:
I have just cleaned the macro with the sheet2 but still trying not to use an extra sheet.

       Application.ScreenUpdating = False

    Sheets("Sheet2").Range("A1:G75000").ClearContents
    
    Sheets("Before").Select
    Range("B:B,E:E,F:F").Select
    Range("F1").Activate
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$C$75000").RemoveDuplicates Columns:=Array(1, 2, 3), _
                                                        Header:=xlYes
    Range("A1:C20").Select
    Selection.Copy
    Sheets("Recap").Select
    Range("BE2").Select
    ActiveSheet.Paste
    Range("BE2").Select

    Application.ScreenUpdating = True

Open in new window

0
Wilder1626Author Commented:
Even better and also by only using Recap sheet

Application.ScreenUpdating = False

    Sheets("Sheet2").Range("BE3:BG75000").ClearContents
    
    Sheets("Before").Select
    Range("B1:B65000,E1:E65000,F1:F65000").Select
    Range("F1").Activate
    Selection.Copy
    Sheets("Recap").Select
    Range("BE2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$BE$2:$BG$65000").RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
    Range("BE2").Select
    
 Application.ScreenUpdating = True

Open in new window

0
Wilder1626Author Commented:
I think i got it now. I think it's a little late for me!!!!!! :)

    Application.ScreenUpdating = False

    Sheets("Recap").Range("BE3:BG75000").ClearContents

   Dim lrow As Long
    lrow = Sheets("Before").Cells(Cells.Rows.Count, "B").End(xlUp).Row
    Sheets("Recap").Range("BE3:BE" & lrow).Value = Sheets("Before").Range("B2:B" & lrow).Value
    Sheets("Recap").Range("BF3:BF" & lrow).Value = Sheets("Before").Range("E2:E" & lrow).Value
    Sheets("Recap").Range("BG3:BG" & lrow).Value = Sheets("Before").Range("F2:F" & lrow).Value

    Application.CutCopyMode = False
    ActiveSheet.Range("$BE$2:$BG$65000").RemoveDuplicates Columns:=Array(1, 2, 3), _
                                                          Header:=xlYes

    Application.ScreenUpdating = True

Open in new window

0
Wilder1626Author Commented:
Again even better. I don't know if it can get better.

    Application.ScreenUpdating = False

    Sheets("Recap").Range("BE3:BG75000").ClearContents

   Dim lrow As Long
    lrow = Sheets("Before").Cells(Cells.Rows.Count, "B").End(xlUp).Row
    Sheets("Recap").Range("BE3:BE" & lrow).Value = Sheets("Before").Range("B2:B" & lrow).Value
    Sheets("Recap").Range("BF3:BF" & lrow).Value = Sheets("Before").Range("E2:E" & lrow).Value
    Sheets("Recap").Range("BG3:BG" & lrow).Value = Sheets("Before").Range("F2:F" & lrow).Value

    Sheets("Recap").Range("BE2:BG" & lrow).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

    Application.ScreenUpdating = True

Open in new window

0
Wilder1626Author Commented:
This is even better for me so far:

    Application.ScreenUpdating = False

    Sheets("Recap").Range("BE3:BG75000").Clear

    Dim lrow As Long
    lrow = Sheets("Before").Cells(Cells.Rows.Count, "B").End(xlUp).Row
    Sheets("Recap").Range("BE3:BE" & lrow).Value = Sheets("Before").Range("B2:B" & lrow).Value

    Columns("BE:BG").NumberFormat = "@"

    Sheets("Recap").Range("BF3:BF" & lrow).Value = Sheets("Before").Range("E2:E" & lrow).Value
    Sheets("Recap").Range("BG3:BG" & lrow).Value = Sheets("Before").Range("F2:F" & lrow).Value
    Sheets("Recap").Range("BE2:BG" & lrow).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

    Columns("BE:BG").HorizontalAlignment = xlCenter

Open in new window

0
Wilder1626Author Commented:
Found out 1 Small issue.

Now fix:
    Application.ScreenUpdating = False

    'Clear final result range
    Sheets("Recap").Range("BE3:BG75000").Clear

    Dim lrow As Long
    lrow = Sheets("Before").Cells(Cells.Rows.Count, "B").End(xlUp).Row + 1
    
    'Put column in Text format & Align xlCenter column on final result
    Columns("BE:BG").NumberFormat = "@"
    Columns("BE:BG").HorizontalAlignment = xlCenter
    
    'Transfer data from One sheet to the other
    Sheets("Recap").Range("BE2:BE" & lrow).Value = Sheets("Before").Range("B1:B" & lrow).Value
    Sheets("Recap").Range("BF2:BF" & lrow).Value = Sheets("Before").Range("E1:E" & lrow).Value
    Sheets("Recap").Range("BG2:BG" & lrow).Value = Sheets("Before").Range("F1:F" & lrow).Value
    
    'Remove duplicate from final list
    Sheets("Recap").Range("BE2:BG" & lrow).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Martin LissOlder than dirtCommented:
Do you still have a problem here?
0
Wilder1626Author Commented:
I'm all good with the last code I've shared.

Thanks for your support :)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.