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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.