بعد فك الدمج يتم تكرار البيانات في الخلايا المدموجة

[alliiia]

السلام عليكم ورحمة الله وبركاته

تقبل الله طاعتكم

كيف يمكن بعد فك الدمج يتم كتابة وتكرار نفس البيانات التي كانت مدموجة

تقرير الطلاب1.xlsb

[alliiia]

جزاكم الله خيرا أساتذتي الكرام 

الحمد لله حصلت على الكود المطلوب في أحد المواقع 

Sub UnMergeSameCell()
 
Dim Rng As Range, xCell As Range
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng
    If Rng.MergeCells Then
        With Rng.MergeArea
            .UnMerge
            .Formula = Rng.Formula
        End With
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[omar elhosseini]

اخى

هل ستفوم بتكرار تنفيذ الكود عشر مرات لعشرة اعمدة

ناهيك عن ان الكود طويل

خليك في المصرى افضل من الاجنبي 

صناعة مصرية خالصة لوجه الله

الكود لعسرة اعمدة مرة واحدة

شاهد المرفق

Sub UnMerge_Rng()
'
Application.ScreenUpdating = False
End_Row = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row + 2
For Col = 1 To 10
    Set Rng = Range(Cells(5, Col), Cells(End_Row, Col))
    With Rng
        .MergeCells = False
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Value = .Value
    End With
Next
Application.ScreenUpdating = True
'
End Sub

تقرير الطلاب1.xlsb

[lionheart]

Sub Test()
    Dim rng As Range, c As Long
    Application.ScreenUpdating = False
        Set rng = Range("A5:J" & Cells(Rows.Count, "D").End(xlUp).Row)
        rng.UnMerge
        For c = 1 To rng.Columns.Count
            With rng.Columns(c)
                On Error Resume Next
                    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
                    If c = 3 Then .Text = .Text Else .Value = .Value
                On Error GoTo 0
            End With
        Next c
    Application.ScreenUpdating = True
End Sub

 

[alliiia]

ما شاء الله تبارك الرحمن

نفع الله بكم أساتذتنا الكرام

إي بالله صدقت

نفخر بوجود أمثالكم، وتقبل الله منكم.

عفوًا أيها الكرام

هل ممكن حل لمسألة الشعبة

مثلا 10\7

مع فك الدمج 

يعطيني تاريخ!!

[lionheart]

It seems you didn't try my code well. Have a look at this line of code

If c = 3 Then .Text = .Text Else .Value = .Value

 

[alliiia]

لقد جربته بالتأكيد أستاذي

والمشكلة كانت أن هذا الملف المرفق أنا سبق وحذفت منه عمود 

لذلك نسخت الكود على ملفي الأصلي فما ضبط، لكن شكرا على التوضيح وفهمت طريقة عمل الكود

If c = 3 Then .Text = .Text Else .Value = .Value

فقط غيرت رقم 3 إلى 4 وضبط معي، ألف شكر أستاذنا الحبيب.

المعذرة على ازعاجك استاذنا قلب الأسد

لكن هل يمكن حذف الصفوف التي تحتوي على كلمة المجموع

طبعا سبق ونزلت موضوع بعنوان: 

كود حذف الصفوف بناء على قيمة محددة

فلو في مجال تعمل لي طريقة تريحني بها

لأن هذا الملف أنا أحمله من نظام الوزارة عندنا

فأحتاج أطبق هذه الأكواد عليها حتى تسرع لي العملية وتوفر لي الوقت

في عمود (المدرسة) راح تجد كلمة المجموع أريد حذف الصف كاملا

طبعا يكون داخل كود فك الخلايا المدمجة لو تكرمت 

واعذرني أثقلت عليك، وأسأل الله يثيبك ويرزقك ويفتح عليك.

تقرير غياب 2019- - - 1 - Copy.xlsb

[lionheart]

Without any code, you can do it in few steps

Filter the column by the word TOTAL then select the rows and delete. That's all

[alliiia]

الله يفتح عليك ما شاء الله

سبحان الله غابت عن بالي، سلمت يداك أخي الحبيب. 

لكن لو في مجال ووقتك يسمح أتمنى عمل ذلك، لماذا؟ لأن بعض الملفات عندي فيها شيتات متعددة (23 شيت)، فالفلترة متعبة، بضطر أعملها وحده وحده، أما بالكود 

أحطها في الوورك بوك (أكتيفيت) وأمشي فيهم على السريع، يضبط معي.