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
Bookmarks