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

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
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

C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
185
NdNoviceHlp
NdNoviceHlp
L
  • Solved
VBA Error
2 3
Replies
29
Views
1K
Joe4
Joe4
F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
291
kvsrinivasamurthy
K
C
  • Solved
Need Help VBA
2
Replies
10
Views
427
Trebor76
T
H
  • Solved
Macro to speedy up process when copying Data
Replies
3
Views
78
Logit
Logit

Forum statistics

Threads
1,223,912
Messages
6,175,340
Members
452,638
Latest member
Oluwabukunmi

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