Manipulation Macro

Thank you!

I ran the code but I am getting a Compile Error: Sub of Function not defined.

Please help

I think I fixed the first error. Now I am getting: Can't execute code in break mode

It worked! Thank you so much. I just need to find out how to delete the empty lines, but that is a small thing.

I have a question with the code you provided:

What if my quantity are not 1 all the time? I want to make sure the quantity is summing and not counting. I manipulated the data to see if that was the case it I think it is counting rather than summing.

Please advise.

Thanks

Updates to code so it produces a total number of rows of data as specified on Totals worksheet cell B4.

Sub CopyEm()
Dim wsOriginal As Worksheet, wsCapture As Worksheet, wsTotal As Worksheet
Dim rg As Range, rgDest As Range
Dim n As Long, nRows As Long, nCols As Long
Set wsOriginal = Worksheets("Sheet1")
Set wsCapture = Worksheets("Sheet2")
Set wsTotal = Worksheets("Sheet3")
wsOriginal.AutoFilterMode = False
wsOriginal.Range("A1").CurrentRegion.AutoFilter
nRows = wsTotal.Range("B4").Value
Set rg = wsOriginal.UsedRange
nCols = rg.Columns.Count

With wsCapture
    .Range("A1").Resize(1, nCols).Value = rg.Rows(1).Value
    Set rg = rg.Offset(1, 0).Resize(nRows, nCols)
    n = .UsedRange.Rows.Count   'Sometimes, this statement will reset the UsedRange to exclude blank rows below your data
    Set rgDest = .UsedRange
    n = .UsedRange.Rows.Count
    nRows = nRows - n + 1
    Set rgDest = rgDest.Cells(n + 1, 1)
    If nRows> 0 Then rgDest.Resize(nRows, nCols).Value = rg.Value
End With

Application.CutCopyMode = False
End Sub

Select allOpen in new window

Your Sheet1 had data in cells R11918 and R16234. I cleared those values, then ran the macro below to reset the used range (and scrollbars):

Sub ExcelDiet()
     
    Dim ws          As Worksheet
    Dim LastRow     As Long
    Dim LastCol     As Long
     
    Application.ScreenUpdating = False
     
    On Error Resume Next
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            LastRow = .UsedRange.Rows.Count
        End With
    Next ws
     
    On Error GoTo 0
     
End Sub

Select allOpen in new window

Hi thanks for all the help. What I am actually looking for is for the macro to look at the number in cell B4 and whatever that total is, copy as many rows that are needed to make up that number. It is the "Quantity" field on sheet 1 that will determine.

So in sheet 1 if I have 10 rows  and in the Quantity column, row 1 = 50, row 2 = 20, row 3 = 4, row 4 = 7, row 5 = 1, row 6 = 2, row 7 = 1, row 8 = 12, row 9 = 1, row 10 = 12
The macro will need to take whatever rows that are needed to make up the 100 in cell B4 on the Totals page. So that could be taking rows 1,2,3,6, 8,12. All of those rows would equal 100.

I hope I explained it better

Much better explanation. Also a much harder problem.

Normally, I use Solver to find the combination of values that add up to an exact sum. As it happens, the free version of Solver that is included with Excel is limited in how many binary constraints it can handle--and the amount of data on wsOriginal worksheet far exceeds that.

As a workaround, I sorted the wsOriginal worksheet by column D (Quantity). I then started taking every row from the top until the sum of rows taken would exceed the value in wsTotal cell B4. If so, I skip that row and continue to the next.

If the above method stops short of copying over the desired total (such as if every quantity was 2 and you wanted a total of 99), then the If Remainder > 0 block of code copies over the row with the smallest quantity. Under most circumstances, this will put the sum of quantity slightly over the target. Under some circumstances (not enough data) you may get two copies of that row and still fail to reach the desired total.

Sub CopyEm()
Dim wsOriginal As Worksheet, wsCapture As Worksheet, wsTotal As Worksheet
Dim rg As Range, rgDest As Range
Dim i As Long, j As Long, jQuant As Long, n As Long, nRows As Long, nCols As Long
Dim Remainder As Double, Quant As Double
Set wsOriginal = Worksheets("Sheet1")
Set wsCapture = Worksheets("Sheet2")
Set wsTotal = Worksheets("Sheet3")
Remainder = wsTotal.Range("B4").Value
jQuant = 4  'Number of column containing Quantity
Set rg = wsOriginal.UsedRange
nRows = rg.Rows.Count
nCols = rg.Columns.Count
wsOriginal.AutoFilterMode = False
wsOriginal.Range("A1").CurrentRegion.AutoFilter
SortByQuantity rg, jQuant    'Sort data by Quantity in column D

With wsCapture
    .UsedRange.ClearContents    'Clear all existing values on worksheet
    Set rgDest = .Range("A1").Resize(1, nCols)
End With

j = 1
rgDest.Value = rg.Rows(1).Value
For i = 2 To nRows
    If IsNumeric(rg.Cells(i, jQuant).Value) Then
        Quant = rg.Cells(i, jQuant).Value
        If (Remainder >= Quant) And (Quant > 0) Then
            Remainder = Remainder - Quant
            j = j + 1
            rgDest.Rows(j).Value = rg.Rows(i).Value
            If Remainder = 0 Then Exit For
        End If
    End If
Next

If Remainder > 0 Then
    For i = nRows To 2 Step -1
        If IsNumeric(rg.Cells(i, jQuant).Value) Then
            Quant = rg.Cells(i, jQuant).Value
            If Quant > 0 Then
                rgDest.Rows(j + 1).Value = rg.Rows(i).Value   'Couldn't get exact total, so go slightly over using wsOriginal row with smallest Quantity
                Exit For
            End If
        End If
    Next
End If
End Sub

Sub SortByQuantity(rg As Range, SortColumn As Long)
With rg.Worksheet
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Select allOpen in new window

Perfect! Thank you for your help! Now what about the other part of the macro that I included on the initial request,to delete the rows from the original sheet that was copied to the Capture sheet.

Please advise.

Thanks again! I have learned alot.

If you want to delete rows from wsOriginal, then it is best to loop through the data from the bottom. Otherwise, you are constantly changing the row index and the number of rows in the table.

I modified the macro to do just that. I changed the sort sub so it sorted in Ascending order rather than Descending. I also reversed the order of the For...Next loops, so the first one went backwards and the second one went forwards.

Sub CopyEm()
Dim wsOriginal As Worksheet, wsCapture As Worksheet, wsTotal As Worksheet
Dim rg As Range, rgDest As Range
Dim i As Long, j As Long, jQuant As Long, n As Long, nRows As Long, nCols As Long
Dim Remainder As Double, Quant As Double
Set wsOriginal = Worksheets("Sheet1")
Set wsCapture = Worksheets("Sheet2")
Set wsTotal = Worksheets("Sheet3")
Remainder = wsTotal.Range("B4").Value
jQuant = 4  'Number of column containing Quantity
Set rg = wsOriginal.UsedRange
nRows = rg.Rows.Count
nCols = rg.Columns.Count
wsOriginal.AutoFilterMode = False
wsOriginal.Range("A1").CurrentRegion.AutoFilter
SortByQuantity rg, jQuant    'Sort data by Quantity in column D

With wsCapture
    .UsedRange.ClearContents    'Clear all existing values on worksheet
    Set rgDest = .Range("A1").Resize(1, nCols)
End With

j = 1
rgDest.Value = rg.Rows(1).Value
For i = nRows To 2 Step -1
    If IsNumeric(rg.Cells(i, jQuant).Value) Then
        Quant = rg.Cells(i, jQuant).Value
        If (Remainder >= Quant) And (Quant > 0) Then
            Remainder = Remainder - Quant
            j = j + 1
            rgDest.Rows(j).Value = rg.Rows(i).Value
            rg.Rows(i).EntireRow.Delete
            nRows = nRows - 1
            If Remainder = 0 Then Exit For
        End If
    End If
Next

If Remainder > 0 Then
    For i = 2 To nRows
        If IsNumeric(rg.Cells(i, jQuant).Value) Then
            Quant = rg.Cells(i, jQuant).Value
            If Quant > 0 Then
                rgDest.Rows(j + 1).Value = rg.Rows(i).Value   'Couldn't get exact total, so go slightly over using wsOriginal row with smallest Quantity
                rg.Rows(i).EntireRow.Delete
                nRows = nRows - 1
                Exit For
            End If
        End If
    Next
End If
End Sub

Sub SortByQuantity(rg As Range, SortColumn As Long)
With rg.Worksheet
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Select allOpen in new window

This macro works perfectly. However, I wanted to know if the items that has no description indicated can be pulled first and then proceed  with the rest of the macro as written.

By "pulled first" do you mean that those rows should be deleted from wsOriginal?

Right pull the one was from the original tab first where there is no description

Shyretta,
I'm sure the word "pull" is clear in your mind--but could you please elaborate for me? By "pull" do you mean "delete those rows from the original worksheet?" Or do you instead mean "don't delete them, but do exclude these rows from the data being copied to the Capture sheet?"

Brad

So what the macro does is take the rows from the first sheet and paste in the capture sheet according to the whatever the number is in B4 then deletes those rows from the 1st sheet which is perfect. I want that to continue.  What I am asking is if the macro can 1st look in the Description column on the first sheet and take the rows where there is no data first to put in the capture sheet then proceed to take whatever remaining rows that are needed to equal B4.

I hope I explained it better

It's a good thing I had you clarify, because I completely missed your goal.

I added a second sort to the Description column data on wsOriginal to put the rows with no description at the bottom. Since the rows to be transferred are taken from the bottom first, that means those rows with a blank description are pulled first.

Sub CopyEm()
Dim wsOriginal As Worksheet, wsCapture As Worksheet, wsTotal As Worksheet
Dim rg As Range, rgDest As Range
Dim i As Long, j As Long, jDesc As Long, jQuant As Long, n As Long, nRows As Long, nCols As Long
Dim Remainder As Double, Quant As Double
Set wsOriginal = Worksheets("Sheet1")
Set wsCapture = Worksheets("Sheet2")
Set wsTotal = Worksheets("Sheet3")
Remainder = wsTotal.Range("B4").Value
jDesc = 3  'Number of column containing Description
jQuant = 4  'Number of column containing Quantity
Set rg = wsOriginal.UsedRange
nRows = rg.Rows.Count
nCols = rg.Columns.Count
wsOriginal.AutoFilterMode = False
wsOriginal.Range("A1").CurrentRegion.AutoFilter
SortData rg, jDesc, jQuant  'Sort data by Quantity in column D and then by Description in column C

With wsCapture
    .UsedRange.ClearContents    'Clear all existing values on worksheet
    Set rgDest = .Range("A1").Resize(1, nCols)
    rgDest.EntireColumn.NumberFormat = "@"
End With

j = 1
rgDest.Value = rg.Rows(1).Value
For i = nRows To 2 Step -1
    If IsNumeric(rg.Cells(i, jQuant).Value) Then
        Quant = rg.Cells(i, jQuant).Value
        If (Remainder >= Quant) And (Quant > 0) Then
            Remainder = Remainder - Quant
            j = j + 1
            rgDest.Rows(j).Value = rg.Rows(i).Value
            rg.Rows(i).EntireRow.Delete
            nRows = nRows - 1
            If Remainder = 0 Then Exit For
        End If
    End If
Next

If Remainder > 0 Then
    For i = 2 To nRows
        If IsNumeric(rg.Cells(i, jQuant).Value) Then
            Quant = rg.Cells(i, jQuant).Value
            If Quant > 0 Then
                rgDest.Rows(j + 1).Value = rg.Rows(i).Value   'Couldn't get exact total, so go slightly over using wsOriginal row with smallest Quantity
                rg.Rows(i).EntireRow.Delete
                nRows = nRows - 1
                Exit For
            End If
        End If
    Next
End If
End Sub

Sub SortData(rg As Range, SortColumn1 As Long, SortColumn2 As Long)
With rg.Worksheet
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Sub ExcelDiet()
     
    Dim ws          As Worksheet
    Dim LastRow     As Long
    Dim LastCol     As Long
     
    Application.ScreenUpdating = False
     
    On Error Resume Next
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            LastRow = .UsedRange.Rows.Count
        End With
    Next ws
     
    On Error GoTo 0
     
End Sub

Select allOpen in new window

SampleQ28989806.xlsm

I did some more testing with data that weren't all the same title, and found a bug. Here is the fix:

Sub CopyEm()
Dim wsOriginal As Worksheet, wsCapture As Worksheet, wsTotal As Worksheet
Dim rg As Range, rgDest As Range
Dim i As Long, j As Long, jDesc As Long, jQuant As Long, n As Long, nRows As Long, nCols As Long
Dim Remainder As Double, Quant As Double
Set wsOriginal = Worksheets("Sheet1")
Set wsCapture = Worksheets("Sheet2")
Set wsTotal = Worksheets("Sheet3")
Remainder = wsTotal.Range("B4").Value
jDesc = 3  'Number of column containing Description
jQuant = 4  'Number of column containing Quantity
Set rg = wsOriginal.UsedRange
nRows = rg.Rows.Count
nCols = rg.Columns.Count
rg.Columns(nCols + 1).FormulaR1C1 = "=COUNTA(RC" & jDesc & ")"
rg.Cells(1, nCols + 1).Value = "Has Desc"
wsOriginal.AutoFilterMode = False
wsOriginal.Range("A1").CurrentRegion.AutoFilter
SortData rg.Resize(, nCols + 1), nCols + 1, jQuant 'Sort data by Quantity in column D and then by Description in column C
rg.Columns(nCols + 1).EntireColumn.Delete

With wsCapture
    .UsedRange.ClearContents    'Clear all existing values on worksheet
    Set rgDest = .Range("A1").Resize(1, nCols)
    rgDest.EntireColumn.NumberFormat = "@"
End With

j = 1
rgDest.Value = rg.Rows(1).Value
For i = nRows To 2 Step -1
    If IsNumeric(rg.Cells(i, jQuant).Value) Then
        Quant = rg.Cells(i, jQuant).Value
        If (Remainder >= Quant) And (Quant > 0) Then
            Remainder = Remainder - Quant
            j = j + 1
            rgDest.Rows(j).Value = rg.Rows(i).Value
            rg.Rows(i).EntireRow.Delete
            nRows = nRows - 1
            If Remainder = 0 Then Exit For
        End If
    End If
Next

If Remainder > 0 Then
    For i = 2 To nRows
        If IsNumeric(rg.Cells(i, jQuant).Value) Then
            Quant = rg.Cells(i, jQuant).Value
            If Quant > 0 Then
                rgDest.Rows(j + 1).Value = rg.Rows(i).Value   'Couldn't get exact total, so go slightly over using wsOriginal row with smallest Quantity
                rg.Rows(i).EntireRow.Delete
                nRows = nRows - 1
                Exit For
            End If
        End If
    Next
End If
End Sub

Sub SortData(rg As Range, SortColumn1 As Long, SortColumn2 As Long)
With rg.Worksheet
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Sub ExcelDiet()
     
    Dim ws          As Worksheet
    Dim LastRow     As Long
    Dim LastCol     As Long
     
    Application.ScreenUpdating = False
     
    On Error Resume Next
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            LastRow = .UsedRange.Rows.Count
        End With
    Next ws
     
    On Error GoTo 0
     
End Sub

Select allOpen in new window

SampleQ28989806.xlsm

I ran the macro and I received the following error and where the error directed me. The screenshots are attached.
Screenshot-error.docx

I just downloaded the workbook posted in my most recent comment and ran the CopyEm macro three times in a row using 64-bit Excel 2016. There was no error message.

I suspect there is something about the data layout in your real workbook that breaks the code. Could you please do the following:
1. Tell me which version of Excel you use. Is it 32-bit or 64-bit? Mac or Windows? Excel 2003, 2007, 2010, 2011, 2013 or 2016?
2. Post a workbook that reproduces the problem.

Windows 10
64 bit
Excel 2013

Here is the macro

Sub AmazonCopyPaste()
Dim wsListing As Worksheet, wsBuffer As Worksheet, wsRemove As Worksheet
Dim rg As Range, rgDest As Range
Dim i As Long, j As Long, jDesc As Long, jQuant As Long, n As Long, nRows As Long, nCols As Long
Dim Remainder As Double, Quant As Double
Set wsListing = Worksheets("Listing")
Set wsBuffer = Worksheets("Buffer")
Set wsRemove = Worksheets("Remove")
Remainder = wsRemove.Range("B4").Value
jDesc = 3  'Number of column containing Description
jQuant = 4  'Number of column containing Quantity
Set rg = wsListing.UsedRange
nRows = rg.Rows.Count
nCols = rg.Columns.Count
rg.Columns(nCols + 1).FormulaR1C1 = "=COUNTA(RC" & jDesc & ")"
rg.Cells(1, nCols + 1).Value = "Has Desc"
wsListing.AutoFilterMode = False
wsListing.Range("A1").CurrentRegion.AutoFilter
SortData rg.Resize(, nCols + 1), nCols + 1, jQuant 'Sort data by Quantity in column D and then by Description in column C
rg.Columns(nCols + 1).EntireColumn.Delete

With wsBuffer
    .UsedRange.ClearContents    'Clear all existing values on worksheet
    Set rgDest = .Range("A1").Resize(1, nCols)
    rgDest.EntireColumn.NumberFormat = "@"
End With

j = 1
rgDest.Value = rg.Rows(1).Value
For i = nRows To 2 Step -1
    If IsNumeric(rg.Cells(i, jQuant).Value) Then
        Quant = rg.Cells(i, jQuant).Value
        If (Remainder >= Quant) And (Quant > 0) Then
            Remainder = Remainder - Quant
            j = j + 1
            rgDest.Rows(j).Value = rg.Rows(i).Value
            rg.Rows(i).EntireRow.Delete
            nRows = nRows - 1
            If Remainder = 0 Then Exit For
        End If
    End If
Next

If Remainder > 0 Then
    For i = 2 To nRows
        If IsNumeric(rg.Cells(i, jQuant).Value) Then
            Quant = rg.Cells(i, jQuant).Value
            If Quant > 0 Then
                rgDest.Rows(j + 1).Value = rg.Rows(i).Value   'Couldn't get exact total, so go slightly over using wsListing row with smallest Quantity
                rg.Rows(i).EntireRow.Delete
                nRows = nRows - 1
                Exit For
            End If
        End If
    Next
End If
End Sub

Sub SortData(rg As Range, SortColumn1 As Long, SortColumn2 As Long)
With rg.Worksheet
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Sub ExcelDiet()
     
    Dim ws          As Worksheet
    Dim LastRow     As Long
    Dim LastCol     As Long
     
    Application.ScreenUpdating = False
     
    On Error Resume Next
   
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
            LastRow = .UsedRange.Rows.Count
        End With
    Next ws
     
    On Error GoTo 0
     
End Sub
Test-Data.xlsx

You had some hidden columns (L:AZ), so I unhid them. I then deleted columns W & X, which had been added by my macro. And I cleared cells R11918 and R16234, which originally contained the text "other-purpose-cases." After having done that, I ran the ExcelDiet sub to reset the used range.

I then ran AmazonCopyPaste with no error message. The attached file is after ExcelDiet, but before AmazonCopyPaste. It runs regardless whether there are hidden columns or not.
Test-DataQ28989806.xlsm

What does the Excel Diet do?

I am getting the same error

Are you getting the error on the file I posted? Or on your real file (that I haven't seen yet)? If the latter, then check the hidden columns for unexpected fragments of text.

ExcelDiet clears the columns to the right of your data and the rows below your data. It then resets the usedrange property of the worksheet. After running it, the scrollbars should take to from beginning to the end of your data--and not far beyond it.

On the real file. That is the one I attached.

So should the Excel Diet run first?

Does the macro in the file you provided get rid of that formula in column W?

No. All the operations I described (deleting columns W:X and clearing the scraps of text in column R, then running ExcelDiet) had been manual steps.

When I tested the code on your workbook without those modifications, it failed. So I added the manual steps to the macro, and now it works at my end.

Sub AmazonCopyPaste()
Dim wsListing As Worksheet, wsBuffer As Worksheet, wsRemove As Worksheet
Dim rg As Range, rgDest As Range
Dim i As Long, j As Long, jDesc As Long, jQuant As Long, n As Long, nRows As Long, nCols As Long
Dim Remainder As Double, Quant As Double
Set wsListing = Worksheets("Listing")
Set wsBuffer = Worksheets("Buffer")
Set wsRemove = Worksheets("Remove")
Remainder = wsRemove.Range("B4").Value
jDesc = 3  'Number of column containing Description
jQuant = 4  'Number of column containing Quantity

ClearUnusedColumns wsListing.Range("A:M")   'Clear all columns except these, then run ExcelDiet sub

Set rg = wsListing.UsedRange
nRows = rg.Rows.Count
nCols = rg.Columns.Count
rg.Columns(nCols + 1).FormulaR1C1 = "=COUNTA(RC" & jDesc & ")"
rg.Cells(1, nCols + 1).Value = "Has Desc"
wsListing.AutoFilterMode = False
wsListing.Range("A1").CurrentRegion.AutoFilter
SortData rg.Resize(, nCols + 1), nCols + 1, jQuant 'Sort data by Quantity in column D and then by Description in column C
rg.Columns(nCols + 1).EntireColumn.Delete

With wsBuffer
    .UsedRange.ClearContents    'Clear all existing values on worksheet
    Set rgDest = .Range("A1").Resize(1, nCols)
    rgDest.EntireColumn.NumberFormat = "@"
End With

j = 1
rgDest.Value = rg.Rows(1).Value
For i = nRows To 2 Step -1
    If IsNumeric(rg.Cells(i, jQuant).Value) Then
        Quant = rg.Cells(i, jQuant).Value
        If (Remainder >= Quant) And (Quant > 0) Then
            Remainder = Remainder - Quant
            j = j + 1
            rgDest.Rows(j).Value = rg.Rows(i).Value
            rg.Rows(i).EntireRow.Delete
            nRows = nRows - 1
            If Remainder = 0 Then Exit For
        End If
    End If
Next

If Remainder > 0 Then
    For i = 2 To nRows
        If IsNumeric(rg.Cells(i, jQuant).Value) Then
            Quant = rg.Cells(i, jQuant).Value
            If Quant > 0 Then
                rgDest.Rows(j + 1).Value = rg.Rows(i).Value   'Couldn't get exact total, so go slightly over using wsListing row with smallest Quantity
                rg.Rows(i).EntireRow.Delete
                nRows = nRows - 1
                Exit For
            End If
        End If
    Next
End If
End Sub

Sub SortData(rg As Range, SortColumn1 As Long, SortColumn2 As Long)
With rg.Worksheet
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .AutoFilter.Sort.SortFields.Add Key:=.Columns(SortColumn2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Sub ClearUnusedColumns(DataRange As Range)
Dim rgDelete As Range
Set rgDelete = DataRange.Cells(1, DataRange.Columns.Count + 1)
With DataRange.Worksheet
    .UsedRange.EntireColumn.Hidden = False
    Set rgDelete = Range(rgDelete, .Cells(1, .UsedRange.Column + .UsedRange.Columns.Count - 1)).EntireColumn
End With
rgDelete.Delete

ExcelDiet DataRange.Worksheet
End Sub

Sub ExcelDiet(Optional ws As Worksheet)
     
    Dim LastRow     As Long
    Dim LastCol     As Long
     
    On Error Resume Next
    If ws Is Nothing Then Set ws = ActiveSheet
        
    With ws
        LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        LastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
        Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
        LastRow = .UsedRange.Rows.Count
    End With
     
    On Error GoTo 0
     
End Sub

Select allOpen in new window

ABSOLUTELY PERFECT!
THANK YOU