- Katılım
- 15 Mart 2005
- Mesajlar
- 42,317
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Selamlar,
Aşağıdaki kodu deneyiniz.
Aşağıdaki kodu deneyiniz.
Kod:
Option Explicit
Sub EŞLEŞENLERİ_AKTAR()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, X As Long, BUL As Range
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set S3 = Sheets("Sayfa3")
S2.Range("A2:C65536").ClearContents
For X = 2 To S1.Range("A65536").End(3).Row
Set BUL = S1.Range("G:G").Find(S1.Cells(X, "B"), LookAt:=xlWhole)
If Not BUL Is Nothing Then
If S1.Cells(X, "D") = WorksheetFunction.Round(BUL.Offset(0, 2), 2) Then
S1.Range("B" & X & ":D" & X).Copy S2.Range("A65536").End(3).Offset(1, 0)
S1.Range("A" & X & ":D" & X).ClearContents
S1.Range("F" & BUL.Row & ":I" & BUL.Row).ClearContents
Else
S1.Range("B" & X & ":D" & X).Copy S3.Range("A65536").End(3).Offset(1, 0)
S1.Range("G" & BUL.Row & ":I" & BUL.Row).Copy S3.Range("E65536").End(3).Offset(1, 0)
S1.Range("A" & X & ":D" & X).ClearContents
S1.Range("F" & BUL.Row & ":I" & BUL.Row).ClearContents
End If
End If
Next
S1.Range("A2:D65536").Sort Key1:=Range("A2"), Order1:=xlAscending
S1.Range("F2:I65536").Sort Key1:=Range("F2"), Order1:=xlAscending
Set BUL = Nothing
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub