+ Reply to Thread
Results 1 to 3 of 3

Copy and paste rows from one worksheet to another based on two criteria

  1. #1
    Registered User
    Join Date
    01-10-2021
    Location
    England
    MS-Off Ver
    Excel 2016
    Posts
    1

    Unhappy Copy and paste rows from one worksheet to another based on two criteria

    Hi all,

    I am trying to put together a macro which copies and pastes certain rows from one work sheet to another, depending on two criteria. For example, I would want the macro to search column D for "Blue" and Column F for "Red". I would also want to only copy certain columns, e.g. D, E, F, G, H, N, U, K. I have included what I have managed to pull together so far, but any help that you could offer would be gratefully received lest I end up tearing my hair out!


    Dim R1, R2, R3, x, Count1 As Integer
    Dim CeRa1, Colour_Type, RAGDt As String
    Dim HCDate As Date
    Dim NewFileFlag, NoMoreFiles As Boolean
    'Dim MovLoc As Object


    Count1 = 0

    CurrentPath = ThisWorkbook.Path

    CurrentFile = ThisWorkbook.FullName

    NewFile = Mid(CurrentFile, InStrRev(CurrentFile, "\") + 1, 999)

    Set ws1 = Workbooks(NewFile).Sheets("Data")

    NewFile1 = Dir$(CurrentPath & "\Data.xl*")

    If NewFile1 = "" Then GoTo EndOfScript:

    Workbooks.Open CurrentPath & ("\") & (NewFile1)

    Set ws2 = Workbooks(NewFile1).Sheets("Data")

    'Below sets an object allowing for file move to new location
    Set MovLoc = CreateObject("scripting.filesystemobject")
    DestPath = CurrentPath & "\Completed\"

    Application.ScreenUpdating = False

    'MsgBox CurrentPath & Chr(13) & Chr(13) & DestPath

    'initialise variables
    NoMoreFiles = False
    R1 = 1
    R2 = 3
    R3 = 4
    x = 1

    NewFileFlag = True

    ' Get first blank space on the data sheet
    Do Until ws1.Range("A" & R1).Value = ""

    R1 = R1 + 1

    Loop

    Do Until NoMoreFiles = True

    If Count1 > 0 And NewFileFlag = True Then

    Workbooks.Open CurrentPath & ("\") & (NewFile1)

    Set ws2 = Workbooks(NewFile1).Sheets("Data")

    R2 = 3

    End If

    If NewFileFlag = True Then

    HCDate = Format(Date, "dd / mm / yyyy")

    NewFileFlag = False

    End If

    Dim lngMatchColNum As Long
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim lngPasteRow As Long


    Do Until ws2.Range("B" & R2).Value = ""

    x = 1

    ws1.Range("A" & R1).Value = HCDate

    ws1.Range("B" & R1).Value = ws2.Range("D" & R2).Value

    ws1.Range("C" & R1).Value = ws2.Range("E" & R2).Value

    ws1.Range("D" & R1).Value = ws2.Range("F" & R2).Value

    ws1.Range("E" & R1).Value = ws2.Range("G" & R2).Value

    ws1.Range("F" & R1).Value = ws2.Range("H" & R2).Value

    ws1.Range("G" & R1).Value = ws2.Range("K" & R2).Value

    ws1.Range("H" & R1).Value = ws2.Range("L" & R2).Value

    ws1.Range("I" & R1).Value = ws2.Range("N" & R2).Value

    ws1.Range("J" & R1).Value = ws2.Range("Q" & R2).Value

    ws1.Range("K" & R1).Value = ws2.Range("S" & R2).Value

    ws1.Range("L" & R1).Value = ws2.Range("U" & R2).Value

    ws1.Range("M" & R1).Value = ws2.Range("X" & R2).Value

    ws1.Range("N" & R1).Value = ws2.Range("AF" & R2).Value

    ws1.Range("O" & R1).Value = ws2.Range("AG" & R2).Value

    ws1.Range("P" & R1).Value = ws2.Range("AH" & R2).Value

    ws1.Range("Q" & R1).Value = ws2.Range("AJ" & R2).Value

    ws1.Range("R" & R1).Value = ws2.Range("AQ" & R2).Value

    ws1.Range("S" & R1).Value = ws2.Range("AR" & R2).Value

    ws1.Range("T" & R1).Value = ws2.Range("AS" & R2).Value

    R1 = R1 + 1
    R2 = R2 + 1

    Loop

    'Closes the newfile - to happen once the data transfer takes place
    Workbooks(NewFile1).Close , False

    'Moves the newfile once it has been closed so that it is out of circulation and completed - prevents duplicate data
    'MovLoc.MoveFile Source:=CurrentPath & ("\") & (NewFile1), Destination:=DestPath

    Count1 = Count1 + 1

    'NewFile1 = Dir$(CurrentPath & "\*PMO Practice RAG Report*.xl*")

    'NewFileFlag = True
    'If NewFile1 = "" Then NoMoreFiles = True
    NoMoreFiles = True

    Loop

    EndOfScript:

    If NewFile1 = "" And Count1 > 0 Then MsgBox ("Data has been transferred from the Check Report onto the Data Sheet.")

    If NewFile1 = "" And Count1 = 0 Then MsgBox ("There were no reports to gather data from.")


    Application.ScreenUpdating = True
    End Sub

  2. #2
    Forum Expert
    Join Date
    10-06-2017
    Location
    drevni ruchadlo
    MS-Off Ver
    old
    Posts
    1,808

    Re: Copy and paste rows from one worksheet to another based on two criteria

    Welcome to the forum,

    With the data layout as in the images below it could look like this:
    Please Login or Register  to view this content.
    Ps:
    Correct the tagging of your "code" in post no. 1
    Attached Images Attached Images

  3. #3
    Forum Expert dangelor's Avatar
    Join Date
    09-06-2011
    Location
    Indiana, USA
    MS-Off Ver
    365 Pro Plus
    Posts
    1,901

    Re: Copy and paste rows from one worksheet to another based on two criteria

    Another possibility...
    Please Login or Register  to view this content.
    ____________________________________________________________
    If I've been helpful, let me know. If I haven't, let me know that too.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] How to copy and paste data into rows based on criteria
    By blucas024 in forum Excel Programming / VBA / Macros
    Replies: 10
    Last Post: 02-24-2020, 12:44 PM
  2. Replies: 19
    Last Post: 09-24-2019, 04:43 AM
  3. [SOLVED] Copy paste rows based on criteria 3 times into a separate worksheet
    By Ganeshgopinath in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 09-08-2015, 09:03 AM
  4. Copy paste rows based on criteria
    By jeff p in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 12-08-2014, 11:00 PM
  5. [SOLVED] Cut and Paste Rows from one worksheet to another based on criteria in two columns
    By GatorsBucs in forum Excel Programming / VBA / Macros
    Replies: 14
    Last Post: 02-08-2013, 12:19 PM
  6. Copy and Paste Rows based on Criteria onto another sheet and sort based on oldest item
    By Kushal8684 in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 01-25-2013, 05:37 AM
  7. Copy Rows That Match Variable Criteria And Paste To A New Worksheet
    By BrodyNoochie in forum Excel Programming / VBA / Macros
    Replies: 7
    Last Post: 03-19-2012, 04:20 PM

Tags for this Thread

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1