PDA

View Full Version : Solved: if match column A and B move the row to another sheet



parscon
03-10-2012, 06:59 AM
I want to use this VBA code but it is not complete currently this VBA check the column A and B matched and afte that move the matched row to another sheet . please help me .



Sub FindAndMove()

Dim i As Long
Dim dCol As Long
Dim lrow As Long

'Column to check first (A)
dCol = 1

'Get last row of data, Col A
lrow = Cells(65536, dCol).End(xlUp).Row

'Check each row: lastrow to row 2
For i = lrow To 2 Step -1

'If Col A AND Col B are match
If Cells(i, 1) = Cells(i - 1, 1) And Cells(i, 2) = Cells(i - 1, 2) Then



End If
Next i
End Sub

Bob Phillips
03-10-2012, 07:52 AM
Don't duplicate your posts!

mancubus
03-10-2012, 09:54 AM
i'm not sure if below is you're after...


Sub FindAndMove()
'http://www.vbaexpress.com/forum/showthread.php?t=41320

Dim wsFrom As Worksheet, wsTo As Worksheet
Dim rngFrom As Range, rngTo As Range
Dim i As Long, lRow As Long, lCol As Long, calc As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

Set wsFrom = Worksheets("Sheet1") 'change Sheet1 to your actual worksheet name with data to move from
Set wsTo = Worksheets("Sheet2") 'change Sheet2 to your actual worksheet name to move to

lRow = wsFrom.Cells(Rows.Count, 1).End(xlUp).Row
lCol = wsFrom.Cells(1, Columns.Count).End(xlToLeft).Column

wsTo.Cells.Clear
wsTo.Cells(1, 1).Resize(1, lCol).Value = wsFrom.Cells(1, 1).Resize(1, lCol).Value 'copy header row

For i = lRow To 2 Step -1
With wsFrom
If .Cells(i, 1) = .Cells(i - 1, 1) And .Cells(i, 2) = .Cells(i - 1, 2) Then
Set rngFrom = .Range(.Cells(i, 1), .Cells(i, lCol))
With wsTo
Set rngTo = .Range("A1").Offset(Application.CountA(.Range("A:A")))
rngTo.Resize(1, lCol).Value = rngFrom.Value
End With
.Rows(i).EntireRow.Delete
End If
End With
Set rngFrom = Nothing
Set rngTo = Nothing
Next i

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = calc
End With

End Sub