Kodlar da düzenleme

[acetinnster]

Arkadaşlar yardımcı olabilirmisiniz açıklamalar ek te ki dosya da

 

[askm]

Aşağıdaki kodları kullanın.

Sub ASKM_Veri_Aktar()
Dim S1, S2 As Worksheet
Set S1 = Sheets("Kesim Listesi")
Set S2 = Sheets("Sayfa1")
Dim SonSat1, SonSat2 As Long


S1.Range("I:I").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range( _
        "CA1"), Unique:=True
SonSat1 = S1.Range("CA" & Rows.Count).End(xlUp).Row
SonSat2 = S1.Range("A" & Rows.Count).End(xlUp).Row
S2.Range("A1:Z5000").ClearContents
x = 1
For i = 2 To SonSat1

S2.Cells(x, 1) = "[P_IIDESC]"
S2.Cells(x, 2) = "[P_IDESC]"
S2.Cells(x, 3) = "[P_DESC1]"
S2.Cells(x, 4) = "[P_LENGTH]"
S2.Cells(x, 5) = "[P_WIDTH]"
S2.Cells(x, 6) = "[P_MINQ]"
S2.Cells(x, 7) = "[P_CODE_MAT]"
S2.Cells(x, 8) = "[P_DESC2]"
S2.Cells(x, 9) = "[P_GRAIN]"
x = x + 1
S2.Cells(x, 1) = "II. Açıklama"
S2.Cells(x, 2) = "I. Açıklama"
S2.Cells(x, 3) = "Açıklama 1"
S2.Cells(x, 4) = "Uzunluk"
S2.Cells(x, 5) = "Genişlik"
S2.Cells(x, 6) = "Asgari Miktar"
S2.Cells(x, 7) = "Materiale"
S2.Cells(x, 8) = "Açıklama 2"
S2.Cells(x, 9) = "Tanecik"

For y = 2 To SonSat2
If S1.Cells(i, "CA") = S1.Cells(y, 9) Then
x = x + 1
S2.Cells(x, 1) = S1.Cells(y, 1)
S2.Cells(x, 2) = S1.Cells(y, 2)
S2.Cells(x, 3) = S1.Cells(y, 3)
S2.Cells(x, 4) = S1.Cells(y, 4)
S2.Cells(x, 5) = S1.Cells(y, 5)
S2.Cells(x, 6) = S1.Cells(y, 6)
S2.Cells(x, 7) = S1.Cells(y, 9)
S2.Cells(x, 8) = S1.Cells(y, 8)
S2.Cells(x, 9) = S1.Cells(y, 11)
End If
Next y
x = x + 2
Next i
S1.Range("CA1:CA5000").ClearContents
MsgBox "Aktarma işlemi tamamlanmıştır.", vbInformation, "ASKM"

End Sub