VBA User selecting file now the code errors Type Mismatch

R

Razor_Rob

Board Regular
Joined
Aug 18, 2022
Messages
63
Office Version
  1. 365
Platform
  1. Windows
Hi everyone,

The code below works fine, then I added a code to make the user select the file that they need to copy from and now the code comes back with an error Type Mismatch.
Sorry just learning as I go....
Also with the code that has Range ie A3:A200 , how can I just make the code go through the whole column while theres data. As the range can change.

Thanks in advance. I really appreciate it.

VBA Code: 
Sub Import_Data()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim lngRow As Long
Dim BotRow As Long
Dim rng As Range
Dim WorkRng As Range
Dim Rng2 As Range
Dim WorkRng2 As Range
Dim Rng3 As Range
Dim WorkRng3 As Range

'Open a workbook
Dim fileNameAndPath As Variant
fileNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If fileNameAndPath = False Then Exit Sub
Workbooks.Open Filename:=fileNameAndPath
        

'Open a workbook

  'Open method requires full file path to be referenced.
 ' Workbooks.Open "\\xxxx\xxx\My Documents\Notifications\Test\Import.xlsx"
  Workbooks.Open "\\xxxx\xxx\\My Documents\Notifications\Test\Import.csv"
  
  'Open method has additional parameters
  'Workbooks.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)
  'Help page: https://docs.microsoft.com/en-us/office/vba/api/excel.workbooks.open


  'Set wsCopy = Workbooks("Import.xlsx").Worksheets(1)
  Set wsCopy = Application.Workbooks.Open(fileNameAndPath).Worksheets(1)
  Set wsDest = Workbooks("Import.csv").Worksheets(1)
  wsDest.Cells.EntireColumn.AutoFit
    
    '1. Find last used row in the copy range based on data in column A
    lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
      
    '2. Find first blank row in the destination range based on data in column A
    'Offset property moves down 1 row
    lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
    
    '3. Clear contents of existing data range
    wsDest.Range("A3:BJ" & lDestLastRow).ClearContents

    '4. Copy & Paste Data
    wsCopy.Range("E2:BN" & lCopyLastRow).Copy _
      wsDest.Range("A3")
      
    '5 Clear contents of non required fields
    wsDest.Range("AQ3:AY200, BB3:BG200" & lDestLastRow).ClearContents
    
    '6. Convert Name to Code
    Cells(Rows.Count, "BH").Select
    Selection.End(xlUp).Select
    BotRow = Selection.Row
    For lngRow = 1 To BotRow
    If InStr(1, Cells(lngRow, "BH").Value, "BAW") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "316070"
    End If
    If InStr(1, Cells(lngRow, "BH").Value, "ASA") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "315191"
    End If
    If InStr(1, Cells(lngRow, "BH").Value, "MEGT") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "335512"
    End If
    If InStr(1, Cells(lngRow, "BH").Value, "MRAEL") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "312280"
    End If
    If InStr(1, Cells(lngRow, "BH").Value, "SARINA") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "341977"
    End If
    If InStr(1, Cells(lngRow, "BH").Value, "SKILLS360") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "348259"
    End If
    If InStr(1, Cells(lngRow, "BH").Value, "MAS") > 0 Then
        Cells(lngRow, "BG") = Cells(lngRow, "BG") & "324274"
    End If
    Next
    
    '7. Add Liability Category
    'wsDest.Range("AF3:AF200").Formula = "=DATEDIF(D3:D200,Now(),""y"")"
     '7a Add Liability Category
     '*******
    Dim objSheet As Worksheet, lngAgeCol As Long, lngEndRow As Long, i2 As Long
    Dim lngStartRow As Long

    With Range("AF3")
        Set objSheet = .Worksheet
        lngAgeCol = .Column
        lngStartRow = .Row + 2
    End With

    lngEndRow = objSheet.Cells.SpecialCells(xlLastCell).Row

    For i2 = lngStartRow To lngEndRow
        objSheet.Cells(i2, lngAgeCol).FormulaR1C1 = "=IF(RC[-28]="""","""",ROUNDDOWN(YEARFRAC(RC[-28],NOW()),0))"
    Next
    '*******
    
    wsDest.Activate
        
    Dim Lastrow As Long
    Dim i As Long
        
    Lastrow = Range("AF" & Rows.Count).End(xlUp).Row
    For i = 3 To Lastrow
        If Range("AF" & i).Value <= 21 Then
            Range("AE" & i).Value = "G2"
        ElseIf Range("AF" & i).Value <= 25 Then
            Range("AE" & i).Value = "G6"
        ElseIf Range("AF" & i).Value > 25 Then
            Range("AE" & i).Value = "O1"
        Else: Range("AE" & i).Value = ""
        End If
    Next i
      
    '7b  Liability
    Cells(Rows.Count, "V").Select
    Selection.End(xlUp).Select
    BotRow = Selection.Row
    For lngRow = 1 To BotRow
    If InStr(1, Cells(lngRow, "V").Value, "School Based") > 0 Then
        Cells(lngRow, "AE") = Cells(lngRow, "AE") & "21"
    End If
    Next
    
    '7c  Liability
    Cells(Rows.Count, "S").Select
    Selection.End(xlUp).Select
    BotRow = Selection.Row
    For lngRow = 1 To BotRow
    If InStr(1, Cells(lngRow, "S").Value, "TRN_FT_A") > 0 Then
        Cells(lngRow, "AE") = Cells(lngRow, "AE") & "O2"
    End If
    If InStr(1, Cells(lngRow, "S").Value, "TRN_PT_A") > 0 Then
        Cells(lngRow, "AE") = Cells(lngRow, "AE") & "O2"
    End If
    Next
      
    '8. Move Employer Name to EmpoyerExternal Org and School Name to Manually Convert and/or Request to Code
    Set WorkRng = Range("AN3:AN200")
    For Each rng In WorkRng
        If rng.Value = 0 Then
            rng.Value = rng.Offset(0, 2).Value

        End If
    Next rng
    
    Set WorkRng2 = Range("AJ3:AJ200")
    For Each Rng2 In WorkRng2
        If Rng2.Value = 0 Then
            Rng2.Value = Rng2.Offset(0, 1).Value

        End If
    Next Rng2
     
    '9. Clear DELTA Qual ID, AASN Name, Employer Name, School Name
    wsDest.Range("AZ3:AZ200,BH3:BH200, AP3:AP200, AK3:AK200, AF3:AF200" & lDestLastRow).ClearContents
        
    Set WorkRng3 = Range("AF3:AF200")
    For Each Rng3 In WorkRng3
        If Rng3.Value = 0 Then
            Rng3.Value = Rng3.Offset(0, -1).Value

        End If
    Next Rng3
    
    ' Liability code clean up for the School Based and Traineeship
    With Columns("AF") '<- Check column
        .Replace what:="G221", replacement:="21", LookAt:=xlWhole, MatchCase:=False
    End With
    With Columns("AF") '<- Check column
        .Replace what:="G2O2", replacement:="O2", LookAt:=xlWhole, MatchCase:=False
    End With
    With Columns("AF") '<- Check column
        .Replace what:="G6O2", replacement:="O2", LookAt:=xlWhole, MatchCase:=False
    End With
    With Columns("AF") '<- Check column
        .Replace what:="O1O2", replacement:="O2", LookAt:=xlWhole, MatchCase:=False
    End With

    '10 Clear Column AE Study Period
    wsDest.Range("AE3:AE200" & lDestLastRow).ClearContents
       
    '11 Remove Qual code in the Qual Title
    With Range("X3", Range("X" & Rows.Count).End(xlUp))
    .Value = Evaluate("=IF({1},MID(" & .Address & ",1,LEN(" & .Address & ")-11))")
    End With
           
    '12 Replace Yes and No to Y and N
    With Columns("BA") '<- Check column
        .Replace what:="Yes", replacement:="Y", LookAt:=xlWhole, MatchCase:=False
        .Replace what:="No", replacement:="N", LookAt:=xlWhole, MatchCase:=False
    End With
    
    '13 Put hypen on School Based
    With Columns("V") '<- Check column
        .Replace what:="School Based", replacement:="School-Based", LookAt:=xlWhole, MatchCase:=False
    End With
    
    '14a Remove spaces from the mobile number
    'Remove multiple spaces from a range
    With wsDest
    .Range("Q3:Q200", .Cells(.Rows.Count, "Q").End(xlUp)).Replace " ", vbNullString, xlPart
    End With
    
    
    '14b Add zero on the student's mob number
    Dim Lastrow2 As Long, cell As Range
    
    
    Lastrow2 = Range("Q" & Rows.Count).End(xlUp).Row       'Last used row in column A
    Range("Q3:Q" & Lastrow2).NumberFormat = "@"            'format range as text
    
    For Each cell In Range("Q3:Q" & Lastrow)
         cell.Value = Format(cell * 1, "0000000000")      'Convert each cell
    Next cell
    Range("Q3:Q" & Lastrow2).Copy Destination:=Range("Q3") 'copy to column C
        
           
    'Proper case for Address 1 and Suburb (Column I and L)
    '[I:L] = [Index(Proper(I:L),)]
    With Range("I3", Cells(Rows.Count, "I").End(xlUp))
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
     With Range("L3", Cells(Rows.Count, "L").End(xlUp))
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
    
    'Clear contents of existing data range
    wsDest.Range("BL2:BL" & lDestLastRow).ClearContents

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub
 
Sort by date Sort by votes
Thanks for helping me out...

Im getting a Run-time error '9': Subscript out of range

on this line
VBA Code: 
Set wsDest = Workbooks("Import.csv").Worksheets(1)
 
Upvote 0

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
I took the comments off on line where you open the Destination file
VBA Code: 
'Workbooks.Open "\\xxxx\xxx\\My Documents\Notifications\Test\Import.csv"

New error comes up - Run-time error '1004'
Method 'Range' of 'object'_Worksheet' failed
highlighted Section 9
VBA Code: 
Intersect(.Rows("3:" & lDestLastRow), .Range("AZ:AZ, BH:BH, AP:AP, A3:AK,AF:AF")).ClearContents
 
Upvote 0
So A3:AK should be AK:AK but I didn't notice the line in the below and it needs to be removed.
(it is overwriting the previous Set wsDest)
VBA Code: 
    Set wsDest = Worksheets(1)
 
Upvote 0
Also right at the bottom these lines need to look like this, not what is there currently

VBA Code: 
    With wsDest.Range("I3:I" & lDestLastRow)
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
    
    With wsDest.Range("L3:L" & lDestLastRow)
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
 
Upvote 0
Can you make the change in my Post #16 and then send me back what you have as being the latest version.
My testing was a bit limited since I don't have either of the worbooks.

We may as well address the objSheet at the same time.
Is the below line writing to wsDest / Import.csv ?

VBA Code: 
    For i2 = lngStartRow To lngEndRow
        objSheet.Cells(i2, lngAgeCol).FormulaR1C1 = "=IF(RC[-28]="""","""",ROUNDDOWN(YEARFRAC(RC[-28],NOW()),0))"
    Next
 
Upvote 0
I've done that and no error on the code
wsDest workbook/sheet has

phone number on column C3 (from column Q)

Cell I3, L3, X3 have #VALUE!
Cell AV3, AW3 AX3, AY3 AZ3 to BF3 etc has no data
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
588
Alex Blakenburg
A
J
  • Question
Combining VBA code together...need help!
Replies
3
Views
199
Fluff
Fluff
N
  • Locked
  • Question
VBA code doesn't work
Replies
3
Views
504
Fluff
Fluff
M
  • Question
Help making my VBA code apply to only one column
Replies
2
Views
101
Alex Blakenburg
A
E
  • Solved
VBA Colour rows in a range containing data with 2 alternating RGB Colours
2
Replies
10
Views
904
Micron
M

Forum statistics

Threads
1,215,643
Messages
6,125,990
Members
449,277
Latest member
Fanamos298

Share this page

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