Error when applying sort

srentiln

New Member
Joined
Dec 10, 2017
Messages
15
Hello again, my adventure in automation with VBA has lead me to a new-to-me issue

What the macro is supposed to do:

1) prompt user for a source data file
2) open source data file, and sort the data by four criteria columns
3) copy data from three of the columns to the destination sheet
4) sort the copied data by two criteria columns and remove rows that are duplicates in both columns
5) copy data from the source, creating dual-column entries in the destination sheet for each unique item in source column 1
6) close source data without saving

Where things are going wrong and what it is telling me:

when applying the first sorting on the source data, it is giving a 1004 error stating that the sort reference is not valid

What I have done so far to try to resolve this:

All the search results I have seen for this error either use the older sort method or boiled down to the user not specifying their target workbook in their key definitions. Neither seems applicable to this case because I am using the newer sort method and my keys all use a sheet object that points at the correct workbook.

My scripting attempt:

VBA Code:
Option Explicit
Dim swb As Workbook
Dim sws As Worksheet
Dim dwb As Workbook
Dim dws As Worksheet

Sub slctsrc()
  Dim fd As Office.FileDialog
  Dim flnm As String
  'open file picker
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  With fd
    .Filters.Clear
    .Filters.Add "Excel Files", "*.xls?", 1
    .Title = "Select the source file"
    .AllowMultiSelect = False
    'user's documents folder
    .InitialFileName = Environ("USERPROFILE") & "\Documents\"
    If .Show = True Then flnm = .SelectedItems(1)
  End With
  'select source data file
  If flnm <> "False" Then
    Set swb = Workbooks.Open(flnm)
    Set sws = swb.Sheets(1)
  End If
  trnsfr
End Sub

Sub trnsfr()
  Dim srng As Range, drng As Range, srt As Range, pos As Range
  Set dwb = ThisWorkbook
  Set dws = dwb.Sheets("Data")
  Set srng = sws.Range("A2")
  Set pos = sws.Cells(srng.End(xlDown).Row, srng.End(xlToRight).Column)
  Set srt = sws.Range(srng.Address & ":" & pos.Address)
  'sort source data by person, course, revision
  With sws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=sws.Range("B2:B" & pos.Row)
    .SortFields.Add Key:=sws.Range("C2:C" & pos.Row)
    .SortFields.Add Key:=sws.Range("E2:E" & pos.Row)
    .SortFields.Add Key:=sws.Range("I2:I" & pos.Row)
    .SetRange srt
    .Header = xlNo
    .MatchCase = False
    .Apply
  End With
  'clear out data sheet and set up first three columns
  dws.Cells.Clear
  Set drng = dws.Range("A2")
  drng.Value = "Course"
  drng.Offset(0, 1).Value = "SOP"
  drng.Offset(0, 2).Value = "Version"
  'add data
  Do While srng <> vbNullString
    drng.Value = srng.Offset(0, 4).Value
    drng.Offset(0, 1).Value = srng.Offset(0, 7).Value
    drng.Offset(0, 2).Value = srng.Offset(0, 8).Value
    Set srng = srng.Offset(1, 0)
    Set drng = drng.Offset(1, 0)
  Loop
  'sort added data by course, revision
  Set pos = dws.Range("C" & dws.Range("A3").End(xlDown).Row)
  Set srt = dwb.Range("A3:C" & pos.Row)
  With dws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=dws.Range("A3:A" & pos.Row)
    .SortFields.Add Key:=dws.Range("C3:C" & pos.Row)
    .SetRange srt
    .Header = xlNo
    .MatchCase = False
    .Apply
    End With
  rmvdp
End Sub

Sub rmvdp()
  Dim rng As Range, chk As Range
  Set rng = dws.Range("A3")
  Set chk = rng.Offset(-1, 0)
  Do While rng.Value <> vbNullString
    'check if course and version are the same as previous
    If rng.Value = chk.Value _
    And rng.Offset(0, 1).Value = chk.Offset(0, 1).Value _
    And rng.Offset(0, 2).Value = chk.Offset(0, 2).Value Then
      dws.Rows(rng.Row).Delete
      Set rng = chk.Offset(1, 0)
    Else
      Set rng = rng.Offset(1, 0)
      Set chk = chk.Offset(1, 0)
    End If
  Loop
  pplt
End Sub

Sub pplt()
  Dim srng As Range, drng As Range, cll As Range
  Dim ref As String
  Dim ndr As Double
  Set srng = sws.Range("A2")
  Set drng = dws.Range("D1")
  ndr = dws.Range("A2").End(xlDown).Row
  Do While srng <> vbNullString
    If drng.Row = 1 Then
      With drng
        .Value = srng.Value
        .Offset(1, 0).Value = "R&U"
        .Offset(1, 1).Value "Qual"
        .Resize(1, 2).MergeCells
        ref = .Text
      End With
      Set drng = dws.Range(drng.Offset(2, 0).Address & ":" & drng.Column & ndr)
    End If
    For Each cll In drng
      If dws.Cells(cll.Row, 1).Value = srng.Offset(0, 4).Value _
      And dws.Cells(cll.Row, 3).Value = srng.Offset(0, 8).Value Then
        If srng.Offset(0, 5).Value = "R&U" Then
          cll.Value = srng.Offset(0, 9).Value
        Else
          cll.Offset(0, 1).Value = srng.Offset(0, 9).Value
        End If
        Exit For
      End If
    Next cll
    Set srng = srng.offet(1, 0)
    If srng.Text <> ref Then
      Set drng = dws.Cells(1, drng.Column + 2)
    End If
  Loop
End Sub

Can anyone spot what I am not seeing that I am doing wrong here?
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top