Kayıt Düzenleme

[omeryılmaz]

Değerli Hocalarım

Veri sayfasındaki verileri örnekte belirttiğim üzere diğer sayfaya düzenleyecek makroya ihtiyacım var.

Konuyu daha önce gönderdim ancak, anlaşılmadığını düşünerek yeni örnekle açıklama gereği duydum. Yardımlarınız için şimdiden teşekkür ediyorum.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Satır As Long, Sıra_No As Long, X As Long, Y As Byte
        
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("TOPLU")
    Satır = 2
    Sıra_No = 1
    S2.Select
    S2.[A2:K65536].ClearContents
    
    For X = 2 To S1.Range("A65536").End(3).Row
        If S1.Cells(X, 1) <> "" Then
        S2.Cells(Satır, 1) = Sıra_No
        S2.Cells(Satır, 2) = S1.Cells(X, 1)
        S2.Cells(Satır, 3) = S1.Cells(X, 2)
        S2.Cells(Satır, 4) = S1.Cells(X, 3)
        S2.Cells(Satır, 5) = S1.Cells(X, 4)
        S2.Cells(Satır, 6) = S1.Cells(X, 5)
        S2.Cells(Satır, 7) = S1.Cells(X, 6)
        S2.Cells(Satır, 8) = S1.Cells(X, 7)
        
            For Y = 8 To S1.Cells(X, 256).End(1).Column Step 3
                If S1.Cells(X, Y) <> "" Then
                If S2.Cells(Satır, 1) = "" Then
                Sıra_No = Sıra_No + 1
                S2.Cells(Satır, 1) = Sıra_No
                End If
                S2.Cells(Satır, 9) = S1.Cells(X, Y)
                S2.Cells(Satır, 10) = S1.Cells(X, Y + 1)
                S2.Cells(Satır, 11) = S1.Cells(X, Y + 2)
                Satır = Satır + 1
                End If
            Next
        
        Sıra_No = Sıra_No + 1
    
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[dEdE]

Merhaba,
Ben de birşeyler hazırlamıştım.

Private Sub CommandButton1_Click()
Set s1 = Sheets("VERİ")
Set s2 = Sheets("TOPLU")
satır = 0
s2.[A2:K65536].ClearContents

For i = 2 To [A65536].End(3).Row
If Cells(i, 1).Value <> "" Then
    ss2 = s2.[I65536].End(3).Row + 1
    s2.Range("B" & ss2 & ":K" & ss2).Value = s1.Range("A" & i & ":J" & i).Value
    satır = satır + 1
    s2.Cells(ss2, 1).Value = satır
    For j = 11 To 50 Step 3
        If s1.Cells(i, j).Value <> "" Then
            ss2 = ss2 + 1
            satır = satır + 1
            s2.Cells(ss2, 1).Value = satır
            s2.Range("I" & ss2 & ":K" & ss2).Value = s1.Range(s1.Cells(i, j), s1.Cells(i, j + 3)).Value
        End If
    Next
End If
Next
MsgBox "Aktarma İşlemi Başarı ile Gerçekleşti.", vbInformation
End Sub