Aynı yevmiye madde numaraları hakkında

[1903emre34@gmail.com]

Merhaba,

yukarıdaki yevmiye madde no aynı olanları (1,3) satırlardan silinmesi ve silerken aralıklarında, iki satır aralık oluşacak şekilde nasıl kod oluşturabiliriz? (istenen sayfa2 manuel yapılmıştır)

 

[askm]

(1,3) den kastınız nedir. Bir de Sayfa2 de neden 20 değer Yevmiye Madde no 3 olanlar yok.

 

[1903emre34@gmail.com]

Sayfa2'deki veriler, yanlışlıkla oldu, düzelttim.

 

[askm]

Aşağıdaki kodları deneyin.

Sub askm_Satir_Sil()
Dim SonSatir, SonSatir2 As Long
SonSatir = Range("A" & Rows.Count).End(xlUp).Row
SonSatir2 = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To SonSatir
    If Cells(i, "A") <> Empty Then
        For k = i + 3 To SonSatir2
            Sayi = WorksheetFunction.CountIf(Range("c2:c" & SonSatir2), Cells(k, 3).Value)
            If Sayi > 2 Then
                For y = 1 To 3
                    If Cells(k, "C") <> Empty Then
                        Rows(k).Delete
                    Else
                        k = k + 1
                        GoTo 10
                    End If
                Next y
            End If
            
        Next k
    End If
10:
Next
SonSatir = Range("A" & Rows.Count).End(xlUp).Row
For i = SonSatir To 3 Step -1
If Cells(i, 3).Value = Empty And Cells(i - 1, 3).Value = Empty Then
    Rows(i).Delete
End If
Next i
SonSatir = Range("C" & Rows.Count).End(xlUp).Row
For i = 3 To SonSatir
If Cells(i, 3).Value = Empty And Cells(i + 1, 3).Value <> Empty Then
    Rows(i).Insert Shift:=xlDown
    i = i + 2
End If
Next i
MsgBox "işlem tamam", vbInformation, "ASKM"
End Sub

 

[1903emre34@gmail.com]

Teşekkürler, kodlar ekteki dosya uyguladım ama olmadı.

Sayfa 1, uygulanan kodlar

Sayfa 2, orgınal sayfa

Sayfa 3, olması istenen sayfa

 

[1903emre34@gmail.com]

Konu güncel

 

[Ziynettin]

Dosyanız ekte, umarım istediğiniz olur.

Sub Aktar()
On Error Resume Next
Set sh = Sheets("Sayfa2")
a = sh.Range("A2:N" & sh.Cells(Rows.Count, 2).End(3).Row)
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a)
    If a(i, 3) <> "" Then
        say = say + 1
        b(say, 1) = a(i, 1)
        b(say, 2) = a(i, 2)
        For y = 4 To UBound(a, 2)
            b(say, y) = a(i, y)
        Next y
        If a(i, 3) = a(i + 1, 3) Then
            n = n + 1
            b(say, 3) = a(i, 3) & "|" & n
         Else
            b(say, 3) = a(i, 3) & "|" & n + 1
            n = 0
        End If
    End If
Next i

tbl = Array(b)
b = Empty
n = Empty
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
say = 0
For i = 1 To UBound(a)
    deg = tbl(0)(i, 3)
    d1(Split(deg, "|")(0)) = d1(Split(deg, "|")(0)) + 1
    If Not d.exists(deg) Then
        say = say + 1
        d.Add deg, say
        For y = 1 To UBound(a, 2)
            b(say, y) = tbl(0)(i, y)
        Next y
        b(say, 3) = Split(deg, "|")(0)
    End If
Next i

tbl = Array(b)
b = Empty: deg = Empty
ReDim b(1 To UBound(a) + d1.Count * 2, 1 To UBound(a, 2))
say = 0
For i = 1 To UBound(a)
    deg = tbl(0)(i, 3)
    If deg <> tbl(0)(i - 1, 3) Then
        say = say + 3
    Else
        say = say + 1
    End If
    For y = 1 To UBound(a, 2)
        b(say - 2, y) = tbl(0)(i, y)
    Next y
Next i
Application.ScreenUpdating = False
With Sheets("Sayfa3")
.Range("A3:N" & Rows.Count).ClearContents
.[A3].Resize(UBound(a) + d1.Count * 2, UBound(a, 2)) = b
.Select
End With
Application.ScreenUpdating = True
MsgBox "İşlem Tamam....", vbInformation
End Sub

 

[1903emre34@gmail.com]

çok teşekkürler,

hayırlı günler