Page 1 of 2 12 LastLast
Results 1 to 10 of 12

VBA: Copy Row from One Workbook to Another

This is a discussion on VBA: Copy Row from One Workbook to Another within the Excel Questions forums, part of the Question Forums category; I have a code which I use to import a large text file into as many worksheets as necessary. Text ...

  1. #1
    New Member
    Join Date
    Mar 2012
    Posts
    37

    Exclamation VBA: Copy Row from One Workbook to Another

    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...

  2. #2
    Board Regular
    Join Date
    Apr 2012
    Posts
    439

    Default Re: VBA: Copy Row from One Workbook to Another

    Hello, nickshep85, do you need to create ImportFile.xls all times? Search the words TRUE or FALSE in Column I do in all sheets PriceFile.xls?

  3. #3
    New Member
    Join Date
    Mar 2012
    Posts
    37

    Question Re: VBA: Copy Row from One Workbook to Another

    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.

  4. #4
    Board Regular
    Join Date
    Apr 2012
    Posts
    439

    Default Re: VBA: Copy Row from One Workbook to Another

    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

  5. #5
    New Member
    Join Date
    Mar 2012
    Posts
    37

    Default Re: VBA: Copy Row from One Workbook to Another

    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

  6. #6
    Board Regular
    Join Date
    Apr 2012
    Posts
    439

    Default Re: VBA: Copy Row from One Workbook to Another

    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

  7. #7
    New Member
    Join Date
    Mar 2012
    Posts
    37

    Default Re: VBA: Copy Row from One Workbook to Another

    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.

  8. #8
    Board Regular
    Join Date
    Apr 2012
    Posts
    439

    Default Re: VBA: Copy Row from One Workbook to Another

    Ok, sorry, i will try. One moment.

  9. #9
    New Member
    Join Date
    Mar 2012
    Posts
    37

    Default Re: VBA: Copy Row from One Workbook to Another

    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

  10. #10
    Board Regular
    Join Date
    Apr 2012
    Posts
    439

    Default Re: VBA: Copy Row from One Workbook to Another

    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

Page 1 of 2 12 LastLast

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com