Loop extracting all data but then causing runtime error 13 (Type Mismatch)

ChrisRamsden

ChrisRamsden

New Member
Joined
Sep 26, 2018
Messages
24
Hi Everyone,

I am a brand new member, although i have been using MrExcel for tips and information for a few years now. I am currently writing an excel macro to pull data from another workbook by finding the number 4 and using offset to pick the cells i want to copy and paste.

The macro is doing it's job but it then causes a Runtime Error 13 - Type Mismatch. It feels like it is running through the loop and then causing an error when it tries to run through again. I have spent hours searching for the answer with no luck so i am calling on all you experts to help teach me something new and help me move forward with my macro:

Code: 
Sub TR1797N1()
Application.ScreenUpdating = False
Dim lRow As Long
Dim cell As Object

'Change text format from single cell to multiple cells
    Windows("TR1797 N1.txt").Activate
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        )), TrailingMinusNumbers:=True
        
'Select data and copy and paste into spreadsheet. This contains a loop through the data

lRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A500")
      
    If Left(cell.Value, 1) = "4" Then
    cell.Select
    ActiveCell.Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 1).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 2).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 4).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 5).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(1, 0).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(6, 2).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(6, 3).Copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate

End If
Next
End Sub

As i am new if i do anything wrong please correct me and i will remember for next time. I know there is probably a better way to do this but if i can just stop the Runtime Error it actually pulls all the information i need. The line where the error is showing is:

Code: 
If Left(cell.Value, 1) = "4" Then

Thank you in advance,

Chris
 
Sort by date Sort by votes
This should deal with the error values
Code: 
LRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & LRow)
   If Not IsError(cell) Then
    If Left(cell.Value, 1) = "4" Then
    cell.Select
    ActiveCell.copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 1).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 2).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 4).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(0, 5).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(1, 0).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(6, 2).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
    ActiveCell.Offset(6, 3).copy
    ThisWorkbook.Activate
    Sheets("TR1797").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    Windows("TR1797 N1.txt").Activate
   End If
End If
Next
Not sure I understand the 2nd part of your request.
 
Upvote 0

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Hi Fluff,

You absolute legend, your most recent code handles the error perfectly. Thank you so much for that as the code now works as i intended.

The second part of my request is in relation to where the code references the workbooks name (TR1797 N1.txt) I have other reports with a similar name (e.g. TR1797 N2.txt, TR1797 N3.txt, etc) which i would like to run through the same code but without having to have 4 or 5 different codes to specifically reference the minor difference in workbook name.

Is there a way to run the code referencing workbooks called TR1797 N*.txt so the number is irrelevant?

I really appreciate your help.

Thank you so much
 
Last edited:
Upvote 0
One option would be
Code: 
Sub TR1797N1()
Application.ScreenUpdating = False
   Dim lRow As Long
   Dim cell As Range
   Dim Wb2 As Workbook
   
   Set Wb2 = ActiveWorkbook
'Change text format from single cell to multiple cells
    Wb2.Activate
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        )), TrailingMinusNumbers:=True
        
'Select data and copy and paste into spreadsheet. This contains a loop through the data

   lRow = Range("A" & Rows.Count).End(xlUp).Row
   For Each cell In Range("A1:A" & lRow)
       If Not IsError(cell) Then
         If Left(cell.Value, 1) = "4" Then
         cell.Select
         ActiveCell.copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 1).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 2).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 4).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 5).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(1, 0).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(6, 2).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(6, 3).copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate

         End If
      End If
   Next cell
End Sub
But the TR1797 N* workbook would need to be the active workbook, when the code is run
 
Upvote 0
Hi Fluff,

Yeah that works an absolute treat. Thank you so much for your assistance. If i could be cheeky can i ask one more question?

Would it be possible to get the following code to select multiple files and run through them all in 1 click? When i press the button a file selector opens and when i select the file it runs the macro. Could that be done to select a few files?

Here is the full code:

Code: 
Sub PullData()
Application.ScreenUpdating = False
Dim lRow As Long
Dim cell As Range
Dim myFile As String
Dim YourFolderPath As Variant
Dim Wb2 As Workbook

YourFolderPath = "C:\Documents and Settings\UPN0OV\Desktop\VISA MACRO"
myFile = Application.GetOpenFilename
If myFile = "False" Then Exit Sub
'MsgBox myFile
Workbooks.Open Filename:=myFile

'Change text format from single cell to multiple cells
    Set Wb2 = ActiveWorkbook
    Wb2.Activate
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        )), TrailingMinusNumbers:=True
        
'Select data and copy and paste into spreadsheet. This contains a loop through the data

lRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lRow)
   If Not IsError(cell) Then
         If Left(cell.Value, 1) = "4" Then
         cell.Select
         ActiveCell.Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 1).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 2).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 4).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(0, 5).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(1, 0).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(6, 2).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
         ActiveCell.Offset(6, 3).Copy
         ThisWorkbook.Activate
         Sheets("TR1797").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Wb2.Activate
   End If
End If
Next

  
'Close spreadsheet from report
Wb2.Close False
ThisWorkbook.Activate
   
'Reactivate screen updating
Application.ScreenUpdating = True
Application.CutCopyMode = False

'Report out the Macro has finished
MsgBox "Macro Complete"
    
End Sub

Thank you
 
Last edited:
Upvote 0
Try
Code: 
Sub PullData()
Application.ScreenUpdating = False
   Dim lRow As Long
   Dim cell As Range
   Dim myFile As Variant
   Dim Wb2 As Workbook
   Dim Fd As Object

   
   With Application.fileDialog(3)
      .InitialFileName = "C:\Documents and Settings\UPN0OV\Desktop\VISA MACRO"
      .Show
      For Each myFile In .SelectedItems
         Set Wb2 = Workbooks.Open(myFile)
         
         Wb2.Activate
         Columns("A:A").Select
         Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
            Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
            )), TrailingMinusNumbers:=True
         
         'Select data and copy and paste into spreadsheet. This contains a loop through the data
         
         lRow = Range("A" & Rows.Count).End(xlUp).Row
         For Each cell In Range("A1:A" & lRow)
            If Not IsError(cell) Then
               If Left(cell.Value, 1) = "4" Then
                  cell.Select
                  ActiveCell.copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(0, 1).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(0, 2).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(0, 4).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(0, 5).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(1, 0).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(6, 2).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(6, 3).copy
                  ThisWorkbook.Activate
                  Sheets("TR1797").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
               End If
            End If
         Next cell
         Wb2.Close False
      Next myFile
   End With
   
   
   'Close spreadsheet from report
   ThisWorkbook.Activate
   
   'Reactivate screen updating
   Application.ScreenUpdating = True
   Application.CutCopyMode = False
   
   'Report out the Macro has finished
   MsgBox "Macro Complete"
   
   End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
VBA Error
2 3
Replies
29
Views
385
Joe4
Joe4
willow1985
  • Solved
Find first blank cell in column A in a Table - Runtime error 91
Replies
4
Views
132
willow1985
willow1985
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
249
ItalianPlatinum
I
A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
755
Joe4
Joe4
B
  • Question
Copy Paste from one Workbook to another
Replies
1
Views
228
rollis13
rollis13

Forum statistics

Threads
1,215,460
Messages
6,124,949
Members
449,198
Latest member
MhammadishaqKhan

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