Consulting

Results 1 to 2 of 2

Thread: CopyRow help for multiple tabs

  1. #1
    VBAX Newbie
    Joined
    Jan 2018
    Posts
    1
    Location

    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
    VBAX Expert
    Joined
    May 2016
    Posts
    604
    Location
    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

Posting Permissions

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