من فضلكم مساعدة بسيطة

[akareem]

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

أرجو من حضراتكم المساعدة 

في الملف المرفق اريد ترحيل حرف R  أو W  في الورقة sheet2  بحيث يتكرر الحرف بنفس العدد المذكور أمامه 

اريد ان يكون الترحيل في صف واحد وليس صفين كما هو في المثال

ويفضل لو كان هناك نطاق خلايا مثلا A1:j1 بحيث لا يتعداه

 

test.xlsx

[أبوعيد]

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

تفضل

test1.xlsx

[محمد هشام.]

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

جرب هدا 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Range, f As String, count As Integer, i As Integer
    If Not Intersect(Target, Me.Range("A1:B2")) Is Nothing Then
        Dim WS As Worksheet: Set WS = Sheets("data")
        Dim xRow As Range: Set xRow = WS.Range("A1:J1")
        Dim tmp As Integer: tmp = xRow.Column
        xRow.ClearContents
        
        For Each n In Me.Range("A1:A2")
            If n.Value <> "" Then
                f = n.Value
                count = n.Offset(0, 1).Value
                For i = 1 To count
                    If tmp > xRow.Columns.count + xRow.Column - 1 Then Exit Sub
                    WS.Cells(xRow.Row, tmp).Value = f
                    tmp = tmp + 1
                Next i
            End If
        Next n
    End If
End Sub

 

 

test2.xlsb

تم تعديل ديسمبر 22, 2024 بواسطه محمد هشام.

[akareem]

جزاكم الله خيرا على الرد وقمتم بجهد مشكور 

 

 

تم تعديل ديسمبر 23, 2024 بواسطه akareem