حذف الخلايا المكررة في اول 5 اعمده

[OmHamza]

السلام عليكم ورحمه الله

لو سمحتو كنت عايزه مساعدة في نموذج الاكسل المرفق

الشيت ده طالع من برنامج المكتب بيطلع بمجموعة من العملاء بس بملاحظات وتواريخ مختلف بس قدام كل تاريخ وملاحظه نفس اسم العميل

عايزه لكل عميل متكرر اسيب اسمه مره واحده بس قدام مجموعة التواريخ والملاحظات زي ما هو باين في الصحفة التانيه في الشيت

يعني انا عايزه اعمل كود او معادلدة تطلعي نفس النتيجه الا موجوده في الشيت رقم 2

taqrer.xlsx

[lionheart]

Sub Test()
    Dim ws As Worksheet, cl As Range, rng As Range, v As String
    Set ws = Sheets("Sheet1")
    With CreateObject("Scripting.Dictionary")
        For Each cl In ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
            v = Join(Application.Index(cl.Resize(, 7).Value, 1, Array(1, 2, 3, 4, 5)), "|")
            If Not .Exists(v) Then
                .Add v, cl
            Else
                If rng Is Nothing Then Set rng = cl Else Set rng = Union(rng, cl)
            End If
        Next cl
    End With
    If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub

 

[OmHamza]

ماشاء الله متشكرة جدا لحضرتك

بس حضرتك الكود بيحذف الصف كله وانا عايزه احذف اول خمس خلايا بس زي ما هو موجود في الاكسل المرفق الشيت 2

انا عايزه نفس النتيجه ال موجوده في الشيت 2

متشكرة جدا لتعب حضرتك

[lionheart]

Option Explicit

Const iCol As Integer = 7

Sub Test()
    Dim e, rng As Range, lr As Long
    Const sOutput As String = "Output"
    Application.ScreenUpdating = False
        Application.DisplayAlerts = False
            On Error Resume Next: Sheets(sOutput).Delete: On Error GoTo 0
        Application.DisplayAlerts = True
        Sheets(1).Copy , Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sOutput
        With Sheets(sOutput)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            .Range("A1").CurrentRegion.Borders.Value = 1
            .Columns("A:F").AutoFit
            With .Columns("G")
                .ColumnWidth = 80
                .Rows("1:" & lr).HorizontalAlignment = xlRight
            End With
            .Range("A1").Resize(, iCol).Interior.Color = RGB(255, 217, 102)
            With .Sort
                .SortFields.Clear
                For Each e In Array("A1", "B1", "C1", "D1", "E1")
                    .SortFields.Add Key:=Range(e), Order:=xlAscending
                Next e
                .SetRange Range("A1:A" & lr).Resize(, iCol)
                .Header = xlYes
                .Apply
            End With
            Set rng = .Range("A2:A" & lr)
            MergeSimilarCells rng
        End With
    Application.ScreenUpdating = True
End Sub

Sub MergeSimilarCells(workRng As Range)
    Dim rng As Range, nRng As Range, xRows As Integer, i As Integer, j As Integer, ii As Integer, cnt As Integer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        xRows = workRng.Rows.Count
        For Each rng In workRng.Columns
            For i = 1 To xRows - 1
                For j = i + 1 To xRows
                    If rng.Cells(i, 1).Value <> rng.Cells(j, 1).Value Then Exit For
                Next j
                Set nRng = workRng.Parent.Range(rng.Cells(i, 1), rng.Cells(j - 1, 1))
                If nRng.Rows.Count > 1 Then
                    For ii = 0 To 4
                        nRng.Offset(, ii).Resize(nRng.Rows.Count).Merge
                    Next ii
                End If
                nRng.Resize(, iCol).BorderAround Weight:=xlThick
                nRng.Offset(, iCol - 1).Resize(nRng.Rows.Count).WrapText = True
                cnt = cnt + 1
                If cnt Mod 2 = 0 Then
                    nRng.Resize(, iCol).Interior.Color = RGB(255, 230, 152)
                Else
                    nRng.Resize(, iCol).Interior.Color = RGB(255, 242, 204)
                End If
                i = j - 1
            Next i
        Next rng
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[OmHamza]

متشكرة جدا لحضرتك والله مش عارفه اقولك ايه 

هو ده ال انا عيزاه بالظبط

جزاك الله خير يارب وربنا يباركلك متشكرة جدا جدا

[محمد حسن المحمد]

سبحان من ألان لداود عليه الصلاة والسلام الحديد وأسال لسليمان عين القطر.

وفوق كل ذي علم عليم

ما شاء الله بارك الله الله ينور.

رائع ما تقدمه أخي الكريم @lionheart

[محمد هشام.]

3 ساعات مضت, wanliii said:

طيب ممكن أفهم كيفية اضافة الكود

 

 

taqrer.xlsm

تم تعديل أغسطس 17, 2022 بواسطه Mohamed Hicham