VBA: Copy Row from One Workbook to Another

nickshep85

New Member
Joined
Mar 21, 2012
Messages
37
I have a code which I use to import a large text file into as many worksheets as necessary. Text to Column is then run on these sheets and a formula added into Column I which returns TRUE or FALSE.

What I need my to do next is select any rows where the value in Cell I is TRUE and paste this into another workbook, ImportFile.xls, onto a tab labelled Mechanical. Where the value in Cell I is FALSE, the row needs to be copied into ImportFile.xls, Tyres tab.

In both of these new tabs, I have headers in Rows 1 & 2, so I would need any data to be inserted from Row 3 onwards.

There are 2 tabs in my original Workbook, PriceFile.xls, as there were 71,000 rows in my text file. The number of sheets may increase or decrease depending on the text files I use.

Can anyone please help me with this code, as I have no idea where I would need to start with this part. I have code that runs up to the creation of ImportFile.xls and inserts the headers on both tabs, but my knowledge is very limited so far and I'm stuck when I get to selecting rows and copying them over.

Many thanks for your help...
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Hello, nickshep85, do you need to create </SPAN>ImportFile.xls all times? Search the words TRUE or FALSE in Column I do in all sheets PriceFile.xls?</SPAN>
 
Upvote 0
Hi Andrew,

The code that I have currently creates ImportFile.xls when the code is run. I'm only using this as a way of transferring the data as I will need to save the sheet as something else later in the process. The code below shows as far as I have got, this creates the file and formats the cells as I require them. From here I'm stuck as I'm new to this, but I need to check each row of each sheet in PriceFile.xls to see whether Cell I states TRUE or FALSE. This row then needs to be transferred to the relevant sheet in ImportFile.xls.

Code:
Sub Transfer_Data()

'Add New Workbook
Workbooks.Add template:=xlWorksheet

      Dim mypath As String
      mypath = ThisWorkbook.Path

'Add New Sheet
ActiveWorkbook.Sheets.Add

      ActiveWorkbook.SaveAs (mypath & "/ImportFile.xls")

'Name Sheets
Sheets("Sheet1").Name = "Tyres"
Sheets("Sheet2").Name = "Mechanical"

Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
    With ws
    .Range("A1").FormulaR1C1 = "=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-5)"

    .Range("B1").FormulaR1C1 = "=today()"
    .Range("B1").Select

    .Range("B1").Copy
    .Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Application.Goto Reference:="R1C1"
    .Application.CutCopyMode = False

    .Range("A2").Value = "CODE"
    .Range("B2").Value = "DESCRIPTION"
    .Range("C2").Value = "XXX"
    .Range("D2").Value = "XXX"
    .Range("E2").Value = "XXX"
    .Range("F2").Value = "XXX"
    .Range("G2").Value = "PRICE"
    .Range("H2").Value = "XXX"
    .Range("I2").Value = "XXX"

    
    End With
    
    Next ws
    
    Sheets.Select
    Range("A1:I2").Select
    With Selection
      .Font.Size = 14
      .Font.Bold = True
      .Font.Color = vbWhite
      .Interior.Color = vbBlue
    End With
    
    
Range("A1").Select
Sheets("Tyres").Select



End Sub

Thanks for your help.
 
Upvote 0
Ok, now we activate first book and start search:
Code:
Workbook(PriceFile.xls).Activate
For i = 1 To Workbook(PriceFile.xls).Sheets.Count
For l = 1 To Cells(Rows.Count, "I").End(xlUp).Row
If Cells(i, 9).Value = "True" Then
.....

Next l
Next i
End Sub
 
Upvote 0
Andrew,

With my limited knowledge, this looks like a good start, but how would I get these rows to copy over into the correct tab in ImportFile.xls
 
Upvote 0
Something like that (untested):
Code:
Workbook(PriceFile.xls).Activate
m = 3
t = 3
For i = 1 To Workbook(PriceFile.xls).Sheets.Count
For l = 1 To Cells(Rows.Count, "I").End(xlUp).Row
If Cells(i, 9).Value = "True" Then
Row(i).Copy
Workbook(ImportFile.xls).Activate
Worksheets("Mechanical").Select
Cells(m, 1).Select
ActiveSheet.Paste
m = m + 1
End If
If Cells(i, 9).Value = "False" Then
Row(i).Copy
Workbook(ImportFile.xls).Activate
Worksheets("Tyres").Select
Cells(t, 1).Select
ActiveSheet.Paste
t = t + 1
End If
Next l
Next i
 
Upvote 0
Andrew,

This code does not transfer any rows across into the ImportFile workbook. I have tried removing the formula that gives my TRUE / FALSE and paste special values to leave just the value, but this does not work either.
 
Upvote 0
If it helps, below is my entire code for this project

Code:
Sub Butt*******()

LargeFileImport
Text_to_Column
Transfer_Data

End Sub


   Sub LargeFileImport()

      'Dimension Variables
      Dim ResultStr As String
      Dim FileName As String
      Dim FileNum As Integer
      Dim Counter As Double
      'Ask User for File's Name
      FileName = ThisWorkbook.Path & "\" & InputBox("Please enter the Text File's name, e.g. test.txt") & ".txt"
      'Check for no entry
      If FileName = "" Then End
      'Get Next Available File Handle Number
      FileNum = FreeFile()
      'Open Text File For Input
      Open FileName For Input As #FileNum
      'Turn Screen Updating Off
      Application.ScreenUpdating = False
      
      Application.DisplayAlerts = False
      
      Dim mypath As String
      mypath = ThisWorkbook.Path
      'Create A New WorkBook With One Worksheet In It
      Workbooks.Add template:=xlWorksheet
      ActiveWorkbook.SaveAs (mypath & "/PriceFile.xls")
      
      Application.DisplayAlerts = True
      
      'Set The Counter to 1
      Counter = 1
      'Loop Until the End Of File Is Reached
      Do While Seek(FileNum) <= LOF(FileNum)
         'Display Importing Row Number On Status Bar
          Application.StatusBar = "Importing Row " & _
             Counter & " of text file " & FileName
          'Store One Line Of Text From File To Variable
          Line Input #FileNum, ResultStr
          'Store Variable Data Into Active Cell
          If Left(ResultStr, 1) = "=" Then
             ActiveCell.Value = "'" & ResultStr
          Else
             ActiveCell.Value = ResultStr
          End If
          
          'For Excel versions before Excel 97, change 65536 to 16384
          If ActiveCell.Row = 65536 Then
             'If On The Last Row Then Add A New Sheet
             ActiveWorkbook.Sheets.Add After:=ActiveSheet
          Else
             'If Not The Last Row Then Go One Cell Down
             ActiveCell.Offset(1, 0).Select
          End If
          'Increment the Counter By 1
          Counter = Counter + 1
      'Start Again At Top Of 'Do While' Statement
      Loop
      'Close The Open Text File
      Close
      'Remove Message From Status Bar
      Application.StatusBar = False
      Application.ScreenUpdating = True
      

   End Sub



Sub Text_to_Column()
Application.ScreenUpdating = False

Workbooks("PriceFile").Activate
Dim LastRow As Long

Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
    With ws
        .Range("A:A").TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, 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)), TrailingMinusNumbers:=True
        
        LastRow = .Cells.Find(What:="*", _
        searchdirection:=xlPrevious, _
        SearchOrder:=xlByRows).Row
        
        .Range("I1:I" & LastRow).FormulaR1C1 = "=ISERROR(SEARCH(LEFT(RC[-8],1),""1234567890"",1))"
        Application.CutCopyMode = False
    End With
    
Next ws

Application.ScreenUpdating = True

End Sub


Sub Transfer_Data()

'Add New Workbook
Workbooks.Add template:=xlWorksheet

      Dim mypath As String
      mypath = ThisWorkbook.Path

'Add New Sheet
ActiveWorkbook.Sheets.Add

      ActiveWorkbook.SaveAs (mypath & "/ImportFile.xls")

'Name Sheets
Sheets("Sheet1").Name = "Tyres"
Sheets("Sheet2").Name = "Mechanical"

Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
    With ws
    .Range("A1").FormulaR1C1 = "=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-5)"

    .Range("B1").FormulaR1C1 = "=today()"
    .Range("B1").Select

    .Range("B1").Copy
    .Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Application.Goto Reference:="R1C1"
    .Application.CutCopyMode = False

    .Range("A2").Value = "CODE"
    .Range("B2").Value = "DESCRIPTION"
    .Range("C2").Value = "XXX"
    .Range("D2").Value = "XXX"
    .Range("E2").Value = "XXX"
    .Range("F2").Value = "XXX"
    .Range("G2").Value = "PRICE"
    .Range("H2").Value = "XXX"
    .Range("I2").Value = "XXX"

    
    End With
    
    Next ws
    
    Sheets.Select
    Range("A1:I2").Select
    With Selection
      .Font.Size = 14
      .Font.Bold = True
      .Font.Color = vbWhite
      .Interior.Color = vbBlue
    End With
    
    
    
Range("A1").Select
Sheets("Tyres").Select


Workbooks(PriceFile.xls).Activate
m = 3
t = 3
For i = 1 To Workbooks(PriceFile.xls).Sheets.Count
For l = 1 To Cells(Rows.Count, "I").End(xlUp).Row
If Cells(i, 9).Value = "True" Then
Rows(i).Copy
Workbooks(ImportFile.xls).Activate
Worksheets("Mechanical").Select
Cells(m, 1).Select
ActiveSheet.Paste
m = m + 1
End If
If Cells(i, 9).Value = "False" Then
Rows(i).Copy
Workbooks(ImportFile.xls).Activate
Worksheets("Tyres").Select
Cells(t, 1).Select
ActiveSheet.Paste
t = t + 1
End If
Next l
Next i


End Sub
 
Upvote 0
Try:
Code:
Sub Transfer_Data()
'Add New Workbook
    Workbooks.Add template:=xlWorksheet
    Dim mypath As String
    mypath = ThisWorkbook.Path
    'Add New Sheet
    ActiveWorkbook.Sheets.Add
    ActiveWorkbook.SaveAs (mypath & "\ImportFile.xls")
    'Name Sheets
    Sheets(1).Name = "Tyres"
    Sheets(2).Name = "Mechanical"
    Dim ws As Worksheet
    On Error Resume Next
    For Each ws In Worksheets
        With ws
            .Range("A1").FormulaR1C1 = "=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-5)"
            .Range("B1").FormulaR1C1 = "=today()"
            .Range("B1").Select
            .Range("B1").Copy
            .Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                             :=False, Transpose:=False
            .Application.Goto Reference:="R1C1"
            .Application.CutCopyMode = False
            .Range("A2").Value = "CODE"
            .Range("B2").Value = "DESCRIPTION"
            .Range("C2").Value = "XXX"
            .Range("D2").Value = "XXX"
            .Range("E2").Value = "XXX"
            .Range("F2").Value = "XXX"
            .Range("G2").Value = "PRICE"
            .Range("H2").Value = "XXX"
            .Range("I2").Value = "XXX"

        End With
    Next ws
    Sheets.Select
    Range("A1:I2").Select
    With Selection
        .Font.Size = 14
        .Font.Bold = True
        .Font.Color = vbWhite
        .Interior.Color = vbBlue
    End With

    Range("A1").Select
    Sheets("Tyres").Select
    
    Workbooks("PriceFile.xls").Activate
    m = 3
    t = 3
    For i = 1 To Workbooks("PriceFile.xls").Sheets.Count
        Worksheets(i).Select
        For l = 1 To Cells(Rows.Count, "I").End(xlUp).Row
            If Cells(l, 9).Value = "True" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Mechanical").Select
                Cells(m, 1).Select
                ActiveSheet.Paste
                m = m + 1
            End If
            If Cells(l, 9).Value = "False" Then
                Rows(l).Copy
                Workbooks("ImportFile.xls").Activate
                Worksheets("Tyres").Select
                Cells(t, 1).Select
                ActiveSheet.Paste
                t = t + 1
            End If
            Workbooks("PriceFile.xls").Activate
            Worksheets(i).Select
        Next l
    Next i
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,205
Members
448,554
Latest member
Gleisner2

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