Consulting

Results 1 to 2 of 2

Thread: CopyRow help for multiple tabs

  1. #1

    CopyRow help for multiple tabs

    Hello! I have a spreadsheet with multiple tabs, and need to copy data from one tab to other tabs, depending on key words in column K. I have the code below that works for one, but need to know how to change it from one to multiple different search criteria and copying to multiple tabs. This copies anything with "Mazak" in column K to the Mazak tab. There are other tabs, Lathe, SL30, Fadal, etc. How can i change the script to search for each of those and copy rows to the correlating tabs? Thanks in advance!!


    Sub CopyRow()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Pop").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    x = 3
    Dim rng As Range
    For Each rng In Sheets("Pop").Range("K3:K" & LastRow)
    If rng = "Mazak" Then
    rng.EntireRow.Copy
    Sheets("Mazak").Cells(x, 1).PasteSpecial xlPasteValues
    x = x + 1
    End If
    Next rng
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End Sub

  2. #2
    Try this, note I have NOT tested this!!!
    Note also I have loaded column K into a variant array, this is because this will really speed up this macro, because you have a multiple loop your a looping through worksheet pop column K and then also through all the worksheet.


    Sub copyrow2() 
         
        Application.ScreenUpdating = False 
        Dim LastRow As Long 
        Dim ws As Worksheet 
        LastRow = Sheets("Pop").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
        Dim x As Long 
         
         
        Dim Inarr As Variant 
         ' load worksheet pop into memory
        Inarr = Worksheets("Pop").Range("K1:K" & LastRow) 
        For Each ws In ActiveWorkbook.Worksheets 
            x = 3 
            If ws.Name <> "Pop" Then 
                For i = 3 To LastRow 
                     
                     
                    If Inarr(i, 1) = Ws.Name Then 
                        Worksheets("pop").Range(i, 1).EntireRow.Copy 
                        ws.Cells(x, 1).PasteSpecial xlPasteValues 
                        x = x + 1 
                    End If 
                Next i 
                 
            Next ws 
            Application.CutCopyMode = False 
            Application.ScreenUpdating = True 
        End Sub 
    
    
    Formatting tags added by mark007

Posting Permissions

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