I am getting a subscript out range error on the line Set wsLr = Workbooks(wsName).Worksheets("F17-F18 Releases")
in the following code can any one help
in the following code can any one help
Code:
Public wbSrc As Excel.Workbook
Dim wsSrc As Worksheet
Dim wsLr As Worksheet
Public wsName As String
Private Sub Filter()
'Dim wb1 As Excel.Workbook
'Set wb1 = Workbooks.Open("C:\Users\Vibc\Downloads\cbc\Copy of PBPTReleaseBookofRecords.xlsx")
Dim i As Date, j As Date
Dim k As String
i = STARTDATE.Value
j = ENDDATE.Value
k = LOBUNIT.Value
Dim m As Long, n As Long
m = i
n = j
Set wbSrc = Workbooks.Open("C:\Users\Vibc\Downloads\cbc\Copy of PBPTReleaseBookofRecords.xlsx")
wbSrc.Worksheets("Item Master").Activate
With wbSrc.Worksheets("Item Master")
wbSrc.Sheets("Item Master").Range("B4").Select
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ActiveSheet.AutoFilterMode = False
.Rows(lastRow + 1).EntireRow.Hidden = True
.Range("E4").AutoFilter Field:=5, Criteria1:=">=" & m _
, Operator:=xlAnd, Criteria2:="<=" & n + 1
.Range("E4").AutoFilter Field:=7, Criteria1:=LOBUNIT.Value
End With
End Sub
Private Function VisibleCells(rng As Range) As Range
Dim r As Range
For Each r In rng
If r.EntireRow.Hidden = False Then
If VisibleCells Is Nothing Then
Set VisibleCells = r
Else
Set VisibleCells = Union(VisibleCells, r)
End If
End If
Next r
End Function
'Main script
Private Sub Execute_Click()
wsName = UserForm1.WorksheetName
'Turn off flickering screen
Application.ScreenUpdating = False
'Filter function
Call Filter
UserForm1.Hide
'Search for ids
Dim cl As Variant, rng As Range
Dim lastRow As Long
lastRow = 0
'Selection.SpecialCells(xlCellTypeVisible).Select
' Sheets("Item Master").Select
'Set rng = wbSrc.Worksheets("Item Master").Range("C:C").Cells
'loop the usedrange
Workbooks.Open Filename:=ThisWorkbook.Path & "" & wsName
' Dim rng4 As Range
' Set rng4 = selectvisiblecolc()
For Each cl In SelectVisibleInColC()
'rng.Cells.SpecialCells (xlCellTypeVisible)
Dim value1 As String
Dim value2 As String
value1 = Replace(Trim(cl.Value), "-", " ")
'Compare id with worksheet-to-extract-to's id
Dim cl2 As Range, rng2 As Range
'Set wsLr = Workbooks("F17-F18 Lending Releases_V1.xlsx").Worksheets("F17-F18 Releases")
Set wsLr = Workbooks(wsName).Worksheets("F17-F18 Releases")
Set rng2 = wsLr.Range("C:C")
Set wsSrc = wbSrc.Worksheets("Item Master")
Dim matchExists As Boolean
matchExists = False
For Each cl2 In rng2
value2 = Replace(Trim(cl2.Value), "-", " ")
If value1 = value2 Then
matchExists = True
wsLr.Cells(cl2.Row, 4).Value = wsSrc.Cells(cl.Row, 4).Value
wsLr.Cells(cl2.Row, 8).Value = wsSrc.Cells(cl.Row, 6).Value
wsLr.Cells(cl2.Row, 21).Value = wsSrc.Cells(cl.Row, 5).Value
wsLr.Range(wsLr.Cells(cl2.Row, "V"), wsLr.Cells(cl2.Row, "CI")).value2 = wsSrc.Range(wsSrc.Cells(cl.Row, "AG"), wsSrc.Cells(cl.Row, "CT")).value2
End If
Next cl2
'if there does not exist a match in the worksheet to be exported, then add the item to the bottom
If matchExists = False Then
Dim lRow As Long
With wsLr
lRow = .Cells(.Rows.Count, "F").End(xlUp).Row
If lastRow = 0 Then
lastRow = lRow + 2
Else
lastRow = lastRow + 1
End If
wsLr.Cells(lastRow, 3).Value = wsSrc.Cells(cl.Row, 3).Value
wsLr.Cells(lastRow, 4).Value = wsSrc.Cells(cl.Row, 4).Value
wsLr.Cells(lastRow, 8).Value = wsSrc.Cells(cl.Row, 6).Value
wsLr.Cells(lastRow, 21).Value = wsSrc.Cells(cl.Row, 5).Value
wsLr.Range(wsLr.Cells(lastRow, "V"), wsLr.Cells(lastRow, "CI")).value2 = wsSrc.Range(wsSrc.Cells(cl.Row, "AG"), wsSrc.Cells(cl.Row, "CT")).value2
End With
End If
Next cl
Workbooks(wsName).SaveCopyAs (ThisWorkbook.Path & "\Filtered_" & wsName)
Unload UserForm1
End Sub
Private Function SelectVisibleInColC() As Range
Dim lRow1 As Long
With wbSrc.Sheets("Item Master")
lRow1 = .Cells(.Rows.Count, 3).End(xlUp).Row
If lRow1 < 3 Then Exit Function
Set SelectVisibleInColC = .Cells(1, 3).Offset(1, 0).Resize(lRow1 - 2).SpecialCells(xlCellTypeVisible)
End With
End Function
Last edited by a moderator:
the code run completely, but nothing is happening. Excel stopped responding ??
