süzerek aktarma

[ferhatgurbuz]

Aşağıdaki kodda A sutunundaki verilere göre diğer sayfalara aktarılıyor

BENİM DOSYADA VERİLER G SUTUNUNDA HANGİ KODU DEĞİŞTİRMEM LAZIM. YARDIMCI OLURSANIZ SEVİNİRİM.


Sub aktar()
Dim i As Integer, k As Integer, sat As Long, var As Byte
Dim sat2 As Long, sat3 As Long, adr1 As String, adr2 As String
Sheets("Genel").Select
Application.ScreenUpdating = False
sat = Cells(65536, "H").End(xlUp).Row
If sat < 2 Then
Application.ScreenUpdating = True
Exit Sub
End If
For i = 2 To Cells(65536, "H").End(xlUp).Row
For k = 1 To Worksheets.Count
If Sheets(k).Name = Cells(i, "H").Value Then
var = 1
Exit For
End If
Next k
If var = 1 Then
var = 0
Else
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Genel").Select
Sheets(Sheets.Count).Name = Cells(i, "H").Value
MsgBox "[ " & Cells(i, "H").Value & " ] İsminde Yeni Bir Sayfa Eklendi.", vbOKOnly + vbInformation, "DİKKAT"
End If
Sheets(Cells(i, "H").Value).Range("A2:E65536").ClearContents
sat2 = 2
sat3 = Cells(65536, "A").End(xlUp).Row
If sat3 < 2 Then
Application.ScreenUpdating = True
Exit Sub
End If
For j = 2 To sat3
If Cells(j, "A").Value = Cells(i, "H").Value Then
adr1 = Range(Cells(j, "A"), Cells(j, "E")).Address
adr2 = Range(Cells(sat2, "A"), Cells(sat2, "E")).Address
Sheets(Cells(i, "H").Value).Range(adr2).Value = Range(adr1).Value
sat2 = sat2 + 1
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam.Aktarma Bitti..!!", vbOKOnly + vbInformation, "AKTARMA"
End Sub

 

[Ayhan Ercan]

Merhaba Sn ferhatgurbuz

A&#351;a&#287;&#305;daki gibi denermisiniz?

Sub aktar()
Dim i As Integer, k As Integer, sat As Long, var As Byte
Dim sat2 As Long, sat3 As Long, adr1 As String, adr2 As String
Sheets("Genel").Select
Application.ScreenUpdating = False
sat = Cells(65536, "H").End(xlUp).Row
If sat < 2 Then
Application.ScreenUpdating = True
Exit Sub
End If
For i = 2 To Cells(65536, "H").End(xlUp).Row
For k = 1 To Worksheets.Count
If Sheets(k).Name = Cells(i, "H").Value Then
var = 1
Exit For
End If
Next k
If var = 1 Then
var = 0
Else
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Genel").Select
Sheets(Sheets.Count).Name = Cells(i, "H").Value
MsgBox "[ " & Cells(i, "H").Value & " ] &#304;sminde Yeni Bir Sayfa Eklendi.", vbOKOnly + vbInformation, "D&#304;KKAT"
End If
Sheets(Cells(i, "H").Value).Range("[COLOR=red][B]G[/B][/COLOR]2:E65536").ClearContents
sat2 = 2
sat3 = Cells(65536, "[COLOR=red][B]G[/B][/COLOR]").End(xlUp).Row
If sat3 < 2 Then
Application.ScreenUpdating = True
Exit Sub
End If
For j = 2 To sat3
If Cells(j, "[COLOR=red][B]G[/B][/COLOR]").Value = Cells(i, "H").Value Then
adr1 = Range(Cells(j, "[COLOR=red][B]G[/B][/COLOR]"), Cells(j, "E")).Address
adr2 = Range(Cells(sat2, "[COLOR=red][B]G[/B][/COLOR]"), Cells(sat2, "E")).Address
Sheets(Cells(i, "H").Value).Range(adr2).Value = Range(adr1).Value
sat2 = sat2 + 1
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "&#304;&#351;lem Tamam.Aktarma Bitti..!!", vbOKOnly + vbInformation, "AKTARMA"
End Sub

 

[ferhatgurbuz]

Hocam ben beceremedim. dosyayı ekliyorum

Ayhan hocam. Ben yapamadım. dosyayı ekliyorum. uyarlarsanız çok sevinirim.

ŞİFRELER 1 DİR.

 

[ferhatgurbuz]

Yukar&#305;daki kod ikinci sat&#305;ra g&#246;re yaz&#305;lm&#305;&#351;. Benim dosyada 4 &#252;nc&#252; sat&#305;rdan ba&#351;l&#305;yor veriler.

bunun i&#231;in nereleri d&#252;zenlemem gerekiyor.