Vba Call function shows subscript out of range

[ipbr21054]

Hi,
In my call function which at present doesnt work i keep seeing an error SUBSCRIPT OUT OF RANGE.
The function should open another worksheet etc but im missing a piece of code to do so.
Do you see the issue here

Thanks

Sub BIKETRANSFERINFO()
'BIKE INFOR SENT FRON INV SHEET TO BIKE INVOICES
  Dim WB As Workbook
  
  With Sheets("INVOICES")
  
  
  Dim x As Long
        Application.ScreenUpdating = False
  
        Workbooks.Open ("C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\MOTORCYCLES.xlsm")
        Worksheets("INVOICES").Activate
        Worksheets("INVOICES").Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
        ActiveWorkbook.Close SaveChanges:=True
    
    Set WB = Workbooks.Open(fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\MOTORCYCLES.xlsm")
        Workbooks("DR.xlsm").Sheets("INV").Range("G13").Copy
        WB.Sheets("INVOICES").Range("A3").PasteSpecial xlPasteValues
        Workbooks("DR.xlsm").Sheets("INV").Range("L16").Copy
        WB.Sheets("INVOICES").Range("B3").PasteSpecial xlPasteValues
        Workbooks("DR.xlsm").Sheets("INV").Range("L15").Copy
        WB.Sheets("INVOICES").Range("C3").PasteSpecial xlPasteValues
        Workbooks("DR.xlsm").Sheets("INV").Range("O14").Copy
        WB.Sheets("INVOICES").Range("D3").PasteSpecial xlPasteValues
        Workbooks("DR.xlsm").Sheets("INV").Range("O17").Copy
        WB.Sheets("INVOICES").Range("E3").PasteSpecial xlPasteValues
        Workbooks("DR.xlsm").Sheets("INV").Range("L13").Copy
        WB.Sheets("INVOICES").Range("F3").PasteSpecial xlPasteValues
        Workbooks("DR.xlsm").Sheets("INV").Range("L4").Copy
        WB.Sheets("INVOICES").Range("G3").PasteSpecial xlPasteValues
        
  
  With Sheets("INVOICES")
    If .AutoFilterMode Then .AutoFilterMode = False
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1:G" & x).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
    Range("A3").Select
  End With
        
        WB.Close True
        End With
End Sub

 

[rondeondo]

Hi,
Can you step through the code and identify which line it throws the error? It may help to narrow down the cause.

I have come across these sorts of issues when a source file has been saved with a last used row of the last available row of a spreadsheet ie, >1000,000. That may not be the case here.

 

[RoryA]

Why do you open a workbook, change, save and close it, then reopen it again immediately?

 

[ipbr21054]

I’ve stepped through the code & found the issue & so now fixed.

@RoryA that is my poor workaround for getting it to work. I am unable to code it correctly so by opening, adding a row & closing my poor code then pasted the values in the newly created row.

Obviously if I could of done it correctly that would of been great. My problem was that I couldn’t get the code to paste correctly hence why you see the A B C range mentioned.
Needed to have it pasted like a previous code you advised before where you used something like using (1,3) (2,4)
Where it represented row being copied from to row it was being pasted to. Unfortunately I couldn’t find it but wish I had as it helped me a lot.

 

[ipbr21054]

Why do you open a workbook, change, save and close it, then reopen it again immediately?

Just found the code from a previous post that you advised.
On my other sheet where i used this code it was copied from a worksheet ro to another worksheet row.

Now im trying to use it BUT from worksheet various cell range to a worksheet row.
I believe ive made to correct edits so far but now at the point shown in red where its referencing cells.
Can you assist please.

Private Sub CommandButton1_Click()
    Dim WB As Workbook, DestWB As Workbook
    Dim ws As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
    On Error Resume Next
    Set DestWB = Application.Workbooks("MOTORCYCLES.xlsm")

    If DestWB Is Nothing Then
        Workbooks.Open fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\MOTORCYCLES.xlsm"
        Set DestWB = Application.Workbooks("MOTORCYCLES.xlsm")
    End If
    On Error GoTo 0

    Set WB = ThisWorkbook
    On Error Resume Next
    Set ws = WB.Worksheets("INV")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Worksheet 'DATABASE' IS MISSING"
        Exit Sub
    End If
 
    Set DestWS = DestWB.Worksheets("INVOICES")
    ColArr = Array("G13:A", "L16:B", "L15:C", "O14:D", "O17:E", "L13:F", "L14:G")
 
    Dim DestNextRow As Long
    With DestWS
        If IsEmpty(.Range("A" & 1)) Then
            DestNextRow = 1
        Else
            DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        End If
    End With

    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With ws
            Set rng = .Cells(Target.Row, SCol)
        End With

        With DestWS
            Set rngDest = .Range(DCol & DestNextRow)
        End With
        rng.Copy
        rngDest.PasteSpecial PASTE:=xlPasteValues
        
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 16
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
   
 
With ActiveWorkbook ' THIS WILL SAVE & CLOSE KEY CODES WORKBOOK
   .Save
   .Saved = True
   .Close
End With
If Target.Column = 1 Then
   If Intersect(Range("A3", Cells(Rows.Count, "A").End(xlUp)), Target) Is Nothing Then Exit Sub
Cancel = True
Database.LoadData Me, Target.Row
End If

End Sub

 

[RoryA]

SCol at that point is a full cell reference like G13, not just a column letter.

 

[ipbr21054]

Hmmm not sure what im supposed to do there.
My goal is to copy cell values from DR.xlsm worksheet INV to a row in the MOTORCYCLE.xlsm worksheet INVOICES.
INV INVOICES
G13 To 1st column
L16 To 2nd colmn
L15 To 3rd column
O14 etc
O17 etc
L13 etc
L14 etc

Either past value to last row or like my poor attempt insert new row at row 3 then paste values there.
My issue without large amounts of code if the transfer between the two sheets

Thanks
What ive down works BUT is messy

 

[RoryA]

Replace this:

        With ws
            Set rng = .Cells(Target.Row, SCol)
        End With

        With DestWS
            Set rngDest = .Range(DCol & DestNextRow)
        End With

with this:

            Set rng = ws.Range(SCol)
            Set rngDest = DestWS.Range(DCol & DestNextRow)

 

[ipbr21054]

Thanks,
Ive now done that & transfers works well.

The code in use is shown below.
All works well in respect of transfer & the sort A-Z that ive added.
BUT
My issue is saving the workbook & without having to confirm YES etc then just close it

Private Sub CommandButton1_Click()
    Dim WB As Workbook, DestWB As Workbook
    Dim ws As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
    On Error Resume Next
    Set DestWB = Application.Workbooks("MOTORCYCLES.xlsm")

    If DestWB Is Nothing Then
        Workbooks.Open fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\MOTORCYCLES.xlsm"
        Set DestWB = Application.Workbooks("MOTORCYCLES.xlsm")
    End If
    On Error GoTo 0

    Set WB = ThisWorkbook
    On Error Resume Next
    Set ws = WB.Worksheets("INV")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Worksheet 'DATABASE' IS MISSING"
        Exit Sub
    End If
 
    Set DestWS = DestWB.Worksheets("INVOICES")
    ColArr = Array("G13:A", "L16:B", "L15:C", "O14:D", "O17:E", "L13:F", "L4:G")
 
    Dim DestNextRow As Long
    With DestWS
        If IsEmpty(.Range("A" & 1)) Then
            DestNextRow = 1
        Else
            DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        End If
    End With

    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
    Set rng = ws.Range(SCol)
    Set rngDest = DestWS.Range(DCol & DestNextRow)
        rng.Copy
        rngDest.PasteSpecial PASTE:=xlPasteValues
        
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 16
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
   
   With Sheets("INVOICES")
    If .AutoFilterMode Then .AutoFilterMode = False
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1:G" & x).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
  End With
     With DestWS
       .Save
       .Saved = True
        WB.Close True
        End With
End Sub

 

[ipbr21054]

This line has sorted it out in replace of the red text zbove

ActiveWorkbook.Close savechanges:=True