değer aktarma

[excel_ance]

arkadaşlar benim sıkıntım kkk belgesinde belirttiğim üzere ana sayfadakı tutarları değer 1 ve değer 2 sayfasına sıralı olarak aktarmak istiyorum yardımcı olursanız sevinirim. yardımlarınız için şimdiden teşekkürler

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Aktar()
    Dim i   As Long, _
        j   As Integer, _
        Son As Long, _
        Tut As Double
    Sheets("ANA SAYFA").Select
    
    'Sayfalar Silindi
    For j = 1 To 2
        Sheets("DEĞER " & j).Range("A2:D50000").ClearContents
    Next j
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
    
        j = 0
        If Cells(i, "C") <> "" Then
            j = 1
            Tut = Cells(i, "C")
        ElseIf Cells(i, "D") <> "" Then
            j = 2
            Tut = Cells(i, "D")
        End If
        If j > 0 Then
            Son = Sheets("DEĞER " & j).Cells(Rows.Count, "A").End(3).Row + 1
            Sheets("DEĞER " & j).Cells(Son, "A") = Cells(i, "A")
            Sheets("DEĞER " & j).Cells(Son, "B") = Cells(i, "B")
            Sheets("DEĞER " & j).Cells(Son, "C") = Tut
            Sheets("DEĞER " & j).Cells(Son, "D") = Cells(i, "E")
        End If
            
    Next i
    
    'Adı Soyadına Göre Sayfalar Sıralanır
    For j = 1 To 2
        Son = Sheets("DEĞER " & j).Cells(Rows.Count, "A").End(3).Row + 1
         Sheets("DEĞER " & j).Range("A2:D" & Son).Sort Key1:=Sheets("DEĞER " & j).[B2]
    Next j
    
    MsgBox "İşlem tamam...."
End Sub

 

[Huseyinkis]

arkadaşlar benim sıkıntım kkk belgesinde belirttiğim üzere ana sayfadakı tutarları değer 1 ve değer 2 sayfasına sıralı olarak aktarmak istiyorum yardımcı olursanız sevinirim. yardımlarınız için şimdiden teşekkürler

Ekteki kodalrı denermisin

Sub aktar()
Set s1 = Sheets("Ana Sayfa")
Set s2 = Sheets("DEĞER 1")
Set s3 = Sheets("DEĞER 2")
s1.Select
For i = 2 To s1.Range("A63536").End(3).Row
If s1.Cells(i, "A").Value = "" Then
GoTo son:
ElseIf s1.Cells(i, "C").Value <> "" Then
s1.Select
s1.Range(Cells(i, "A"), Cells(i, "E")).Select
Selection.Copy
s2.Select
Satır1 = s2.Range("A63536").End(3).Row + 1
s2.Cells(Satır1, "A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ElseIf s1.Cells(i, "D").Value <> "" Then
s1.Select
s1.Range(Cells(i, "A"), Cells(i, "E")).Select
Selection.Copy
s3.Select
Satır2 = s3.Range("A63536").End(3).Row + 1
s3.Cells(Satır2, "A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
son:
Next
End Sub

 

[excel_ance]

teşekkürler arkadaşlar. elinize emeğinize sağlık.