I do have the network directory path in my code, but I am now finding out
that some do not use the same letter. So far I have some where they used G,
R and L. Can I just use the whole path name? When she tries to run it, she
gets a message that the file can not be found.
Here is my code:
Sub ExtractCodes()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("AllCrosswalkCodes")
Set rng = Range("CodesDatabase")
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean
'refresh all codes data from the most current RIMS text file
'Selection.QueryTable.Refresh BackgroundQuery:=False
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;R:\IntegFinanceTeam\Crosswalk\crosswalkreport.csv",
Destination:=Range( _
"A2"))
.Name = "crosswalkreport_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 3)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Columns("A:G").Select
Columns("A:G").EntireColumn.AutoFit
Range("A2").Select
'extract a list of Modality Codes
ws1.Columns("A:A").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row
'set up Criteria Area
Range("L1").Value = Range("A1").Value
For Each c In Range("J2:J" & r)
'add to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("AllCrosswalkCodes").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Columns("A:G").Select
Columns("A:G").EntireColumn.AutoFit
'Columns.AutoFit
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("AllCrosswalkCodes").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Columns("A:G").Select
Columns("A:G").EntireColumn.AutoFit
'Columns.AutoFit
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
SortDescending = False
If ActiveWindow.SelectedSheets.Count = 1 Then
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index <> .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If
For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
End If
Next N
Next M
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
