• 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.

Copy data, sort and remove

Ww01

New Member
Hi

I have two Sheets, Data and Summary I am trying to summarise the information on the Data sheet and remove Data that has no data. I want to copy columns of data to the Summary sheet and put the information at the bottom. Can’t seem to work it out. Process is below for you all.

Thanks

Wendy

Code:
Sub Macro1()
'
' Macro1 Macro
'
'
    Range("O2").Select
    ActiveCell.FormulaR1C1 = ""
    Range("N2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]*1000"
    Selection.AutoFill Destination:=Range("N2:N50"), Type:=xlFillDefault
    Range("N2:N50").Select
    ActiveWindow.SmallScroll Down:=-38
    Range("N2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-18
    Range("M2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Style = "Comma"
    Selection.NumberFormat = "_-$* #,##0.0_-;-$* #,##0.0_-;_-$* ""-""??_-;_-@_-"
    Selection.NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
    Range("A:A,M:M").Select
    Range("M1").Activate
    Selection.Copy
    Sheets("Summary").Select
    ActiveWindow.SmallScroll Down:=12
    Range("A50").Select
    ActiveWindow.SmallScroll Down:=-16
    Sheets("Data").Select
    ActiveWindow.SmallScroll Down:=-6
    Range("A2:A50").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Summary").Select
    ActiveWindow.SmallScroll Down:=-6
    Range("A2").Select
    Selection.End(xlDown).Select 'Add one row
    ActiveSheet.Paste
    Sheets("Data").Select
    Range("M2:M50").Select
    Range("M50").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Summary").Select
    Range("B2").Select
    Selection.End(xlDown).Select 'Add one row
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Data"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Amt"
    Range("B1").Select
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
    Range("A1:C26").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Data").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("M2:M50"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Data").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]*0.15"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C50"), Type:=xlFillDefault
    Range("C2:C50").Select
    ActiveWindow.SmallScroll Down:=-32
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Commission"
    Range("C2").Select
    Columns("C:C").EntireColumn.AutoFit
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Style = "Percent"
    ActiveCell.FormulaR1C1 = "=RC[-1]*0.15"
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-20
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C50")
    Range("C2:C50").Select
    Selection.Style = "Currency"
    Selection.NumberFormat = "_-$* #,##0.0_-;-$* #,##0.0_-;_-$* ""-""??_-;_-@_-"
    Selection.NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
    Range("B2").Select
'zero
Dim x As Integer
    For x = 2 To 100
    If Range("B" & "X") = 0 Then
        Range("X").Select
        Range("X").Row.Delete
    End If
    Next
     
End Sub
 
Hi Wendy

From what I can tell you want to copy two Columns - Description of your Data - and Amount to your summary sheet. Add a Commission Column which is 15%. Sort the data then remove any blank or zero items. Would that be correct?

Take care

Smallman
 
Hi Smallman

Essentially that is what I am attempting. Still can't get it working though.

Wendy
 
Hi Wendy

Give the following a try. Should replace your code above. Last 2 rows replace your loop.

Code:
Option Explicit
 
Sub testo()
Dim ar As Variant
Dim lr As Long
Dim sh As Worksheet
Set sh = Sheet2
 
lr = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:A" & lr & ", M2:M" & lr).Copy Sheet2.[a2]
ar = [{"Data", "Amount", "Commission"}]
Sheet2.[a1:c1] = ar
 
sh.[d1] = 1000: sh.[d1].Copy
sh.Range(sh.Cells(2, 2), sh.Cells(sh.Cells(Rows.Count, 1).End(xlUp).Row, 2)).PasteSpecial 1, 4
sh.Range(sh.Cells(2, 3), sh.Cells(sh.Cells(Rows.Count, 1).End(xlUp).Row, 3)) = "=B2*0.15"
sh.Range("A2", sh.Range("C65536").End(3)).Sort sh.[C2], 2
sh.Range("A2", sh.Range("C65536").End(3)).Style = "Currency"
'Replaces the Blank
sh.Range("A2", sh.Range("C65536").End(3)).AutoFilter 3, "$-"
sh.Range("A2", sh.Range("C65536").End(3)).EntireRow.Delete
End Sub

Take care

Smallman
 
You have to watch out for the Sheets in your workbook. If your summary sheet is Sheet2 (codename) then you should be good. Also you didn’t supply a workbook so I had to do the best with what was available. Just ran the data on an indicative data set. :) Your code told me what the data looks like.

Smallman
 
Got it, summary was sheet4. How do I put the data at the last used row of summary sheet?
 
If you are putting the data in the Summary sheet at the bottom of the dataset then why do you need to put the headings there each time?

Code:
ar = [{"Data", "Amount", "Commission"}]

Surely the Summary sheet is waiting for the data with the headings already there.

Take care

Smallman
 
Just replace this line;
Code:
Range("A2:A" & lr & ", M2:M" & lr).Copy Sheet2.[a2]
with this line;
Code:
Range("A2:A" & lr & ", M2:M" & lr).Copy sh.[a65536].End(3)(2)
I see an error of sorts, the first line should have had my variable Sh instead of Sheet2 but it won't effect the operation of the code. I must have developed the code and added the variable when I started seeing some long lines that needed shortening.

Take care

Smallman
 
This seems to work OK at my end.

Code:
Option Explicit
 
Sub testo()
Dim lr As Long
Dim sh As Worksheet
Set sh = Sheet2
 
lr = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:A" & lr & ", M2:M" & lr).Copy sh.[a65536].End(3)(2)
 
sh.[d1] = 1000: sh.[d1].Copy
sh.Range(sh.Cells(2, 2), sh.Cells(sh.Cells(Rows.Count, 1).End(xlUp).Row, 2)).PasteSpecial 1, 4
sh.Range(sh.Cells(2, 3), sh.Cells(sh.Cells(Rows.Count, 1).End(xlUp).Row, 3)) = "=B2*0.15"
sh.Range("A2", sh.Range("C65536").End(3)).Sort sh.[C2], 2
sh.Range("A2", sh.Range("C65536").End(3)).Style = "Currency"
'Replaces the Blank
sh.Range("A2", sh.Range("C65536").End(3)).AutoFilter 3, "$-"
sh.Range("A2", sh.Range("C65536").End(3)).EntireRow.Delete
End Sub

Take care

Smallman
 
If you could post a file I would not be guessing. There is an upload facility or there is sky drive share sites too.

Smallman
 
Not able to from my current location. If you post what you have it might help me see it going.

Thanks
 
OK

Here is the file. I had to change the code slightly as the change in requirements needed a trap of the last row for the 15% Commission formula. Here is the associated code and the file.

Code:
Option Explicit
 
Sub testo()
Dim lr As Long
Dim lw As Long
Dim sh As Worksheet
Set sh = Sheet2
 
lr = Range("A" & Rows.Count).End(xlUp).Row
lw = sh.Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A2:A" & lr & ", M2:M" & lr).Copy sh.[a65536].End(3)(2)
 
sh.[d1] = 1000: sh.[d1].Copy
sh.Range(sh.Cells(lw, 2), sh.Cells(sh.Cells(Rows.Count, 1).End(xlUp).Row, 2)).PasteSpecial 1, 4
sh.Range(sh.Cells(lw, 3), sh.Cells(sh.Cells(Rows.Count, 1).End(xlUp).Row, 3)) = "=B" & lw & "*0.15"
sh.Range("A2", sh.Range("C65536").End(3)).Sort sh.[C2], 2
sh.Range("B2", sh.Range("C65536").End(3)).Style = "Currency"
'Replaces the Blank
sh.Range("A1", sh.Range("C65536").End(3)).AutoFilter 3, "$-"
sh.Range("A2", sh.Range("C65536").End(3)).EntireRow.Delete
sh.[a1].AutoFilter
End Sub

Take care

Smallman
 

Attachments

  • Data1.xlsm
    24 KB · Views: 4
Yeah just replace the following line.

Code:
sh.Range(sh.Cells(lw, 3), sh.Cells(sh.Cells(Rows.Count, 1).End(3).Row, 3)) = "=B" & lw & "*" & [Com]

Take care

Smallman
 
Sorry I forgot to mention the Com is a named range for the commission amount. You could use a cell reference also

[a1] but if it is on a different sheet make sure you precede the cell with the sheet code name.

Sheet1.[a1]

Take Care

Smallman
 
Back
Top