Solved: VBA Copy and Paste Specific Cells Based On Another Cells Value

Hi, I wonder whether someone may be able to help me please.

I've put together the following code which, carries out the following procedure:

• Starting at row 7 on the "Input" sheet, check to see if there is a value in column B.
• If present, then search for the value "P" in column I and "I" in column L.
• If these criteria are met, copy the value in column J and paste into column B on the "In Flights Project" page.

[vba]
Option Explicit
Sub InFlightProjects()
Dim LR As Long, i As Long
Sheets("In Flight Projects").Range("B7:B1307").Cells.ClearContents
With Sheets("Input")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For i = 7 To LR
With .Range("J" & i)
If .Offset(, -1).Value = "P" And .Offset(, 2) = "I" Then Sheets("In Flight Projects").Cells(Application.Max(Sheets("In Flight Projects").Cells(Rows.Count, "B").End(xlUp).Row + 1, 7), "B").Value = .Value
End With
Next i
End With
Columns("A:M").EntireColumn.AutoFit
End Sub

[/vba]

The code works fine but I'm having a little difficulty in exanding the copy and paste ranges.

What I would like to do is instead of just copying the value in column J, I'd like to copy the values in columns J, K and O, and paste these into the columns B,C and D respectively, whilst maintainig the rest of the functionality.

I just wondered whether someone could possibly look at this please and offer soem guidance on how I may be able to achieve this.

Many thanks and kind regards

perhaps...

[VBA]
Option Explicit

Sub InFlightProjects()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim LR1 As Long, LR2 As Long, i As Long

Set ws1 = Sheets("Input")
Set ws2 = Sheets("In Flight Projects")

ws2.Range("B7:B" & Rows.Count).ClearContents

LR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
If LR1 < 7 Then MsgBox "No data to copy!": Exit Sub 'checks if a value exits after row 6 in col B

For i = 7 To LR
If ws1.Range("J" & i).Offset(, -1).Value = "P" And ws1.Range("J" & i).Offset(, 2).Value = "I" Then
LR2 = ws2.Cells(Application.Max(ws2.Cells(Rows.Count, "B").End(xlUp).Row + 1, 7))
' or???
'LR2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row + 1
ws2.Cells(LR2, "B").Value = ws1.Cells(i, "J").Value
ws2.Cells(LR2, "C").Value = ws1.Cells(i, "K").Value
ws2.Cells(LR2, "D").Value = ws1.Cells(i, "O").Value
End If
Next i

ws2.Columns("A:M").EntireColumn.AutoFit

End Sub
[/VBA]

Hi @mancubus, thank you for taking the time to reply to my post and for putting the solution together.

I've tried the code you kindly sent, in both Excel 2003 and 2013, and unfortunately, although I receive no error message, the code doesn't copy anything from the Source sheet.

Many thanks and kind regards

hi and you're welcome...

possible reason for that is conditions regarding column I and L were not met.

can you post the workbook with fake/representative data.

attached is a working example...


[VBA]
Option Explicit

Sub InFlightProjects()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim LR1 As Long, LR2 As Long, i As Long

Set ws1 = Sheets("Input")
Set ws2 = Sheets("In Flight Projects")

ws2.Range("B7:B" & Rows.Count).ClearContents

LR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
If LR1 < 7 Then MsgBox "No data to copy!": Exit Sub 'checks if a value exits after row 6 in col B

For i = 7 To LR1
If ws1.Range("I" & i).Value = "P" And ws1.Range("L" & i).Value = "I" Then
LR2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row + 1
ws2.Cells(LR2, "B").Value = ws1.Cells(i, "J").Value
ws2.Cells(LR2, "C").Value = ws1.Cells(i, "K").Value
ws2.Cells(LR2, "D").Value = ws1.Cells(i, "O").Value
ws2.Cells(LR2, "Q").Value = i 'to return row nums which meet conditions. remove this line after testing.
End If
Next i

ws2.Columns("A:M").EntireColumn.AutoFit

End Sub
[/VBA]


PS:
change
For i = 7 To LR
in second post to
For i = 7 To LR1

Hi @mancubus, thank you very much for taking the time in continuing to support me with this.

The code works great, but there is just one small tweak that I'd like to make if at all possible.

If I run the current script, the correct values are copied and paste into the correct 'Destination' sheet and cells.

But could you possibly tell me please how I may change this so that the first row which the values are copied into is row 7 rather than the row 2.

Many thanks and kind regards

Chris

you are welcome.

copy to "In Flight Projects" starting at row 7 and increment the row number by 1 at each matching criteria.

[vba]
Option Explicit

Sub InFlightProjects()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim LR1 As Long, LR2 As Long, i As Long

Set ws1 = Sheets("Input")
Set ws2 = Sheets("In Flight Projects")

ws2.Range("B7:B" & Rows.Count).ClearContents

LR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
If LR1 < 7 Then MsgBox "No data to copy!": Exit Sub 'checks if a value exits after row 6 in col B

LR2 = 7
For i = 7 To LR1
If ws1.Range("I" & i).Value = "P" And ws1.Range("L" & i).Value = "I" Then
ws2.Cells(LR2, "B").Value = ws1.Cells(i, "J").Value
ws2.Cells(LR2, "C").Value = ws1.Cells(i, "K").Value
ws2.Cells(LR2, "D").Value = ws1.Cells(i, "O").Value
End If
LR2 = LR2 + 1
Next i

ws2.Columns("A:M").EntireColumn.AutoFit

End Sub
[/vba]

Hi @mancubus, thank you very much for this.

I've incorporated the revised code into my script and although the first row now correctly pastes into row 7 which is great, thank you, there is a gap of 7 rows between each row of data.

Many thanks and kind regards

Chris

oooppps... sorry...

please move LR2 = LR2 + 1 bit two lines above... just before End If. this makes row num increment by 1 when the conditions are met.

Hi @mancubus, thank you very much for this, it works perfectly.

Thank you very much for all your time and trouble with this, it is greatly appreciated.

All the best and kind regards

Chris

you are most welcome.

im glad it helped :)

hi i am recently join this forum.
i have little problem with copy one single word & paste it in another column based on value..
i have one sheet with heading column A = sr no. B=part No , C= Qty, D= Value , E="FMS"

and a3=F, a4=M,a5=S
and b3=20000, b4=40000, b5=90000

i would like to paste WORDS FMS in column E based on VALUE OF COLUMN D
MEANS if value of a cell in column D is < 20000 then in column E auto paste the word F
please see attached file

thanks in advance
i am very new for using vba please help me