تعديل كود يقوم بترحيل البيانات الى شيت محدد باسم خليه محدده

[محمد عبد الناصر]

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

في هذا الكود يقوم بترحيل البيانات الى شيت محدد على حسب اسم الشيت المكتوب في الخليه C2 

اريد تعديل هذا الكود بحيث اذا لم يجد بيانات في العمود B10:B20 لا يقوم بترحيل اي صفوف فارغة ولا يفعل اي شيء 

لان عند الضغط عليه يقوم بترحيل صفوف فارغه 

Sub SSheet()
Dim ws As Worksheet, Data As Worksheet, ShName As String
Dim LR As Long, ER As Long, x As Integer
Set Data = Sheets("المدخلات")
ShName = Data.Range("C2").Text
ER = Data.Range("B" & Rows.Count).End(3).Row
x = ER - 7
For Each ws In Worksheets
If ws.Name = ShName Then
LR = ws.Range("B" & Rows.Count).End(3).Row
ws.Name = ShName
ws.Range("B" & LR + 1).Resize(x, 11) = Data.Range("B10").Resize(x, 11).Value
End If
Next
End Sub

 

[أبومروان]

ممكن تستخدم if إذا كان النطاق فارغ يقوم الخروج من الsub كالاتي 

if sheet1.range("b10:b20"). value then Exide sub
 end if 

 

[محمد عبد الناصر]

3 دقائق مضت, كريم نظيم said:

ممكن تستخدم if إذا كان النطاق فارغ يقوم الخروج من الsub كالاتي 

if sheet1.range("b10:b20"). value then Exide sub
 end if 

 

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

[محمد هشام.]

تفضل اخي 

Sub SSheet_2()
Dim ws As Worksheet, Data As Worksheet, ShName As String
Dim LR As Long, ER As Long, x As Integer
Set Data = Sheets("المدخلات")
Dim rng As Range
ShName = Data.Range("C2").Text
ER = Data.Range("B" & Rows.Count).End(3).Row
x = ER - 7
Dim Plage As Range
Dim i As Byte
With Data
    Set Plage = Union(.Range("b10:b20"), .Range("b20"))
    For i = 1 To Plage.Count
        If Plage(i) = "" Then MsgBox ("يرجى ملا الخلية " & Plage(i).Address): Exit Sub
    Next
End With

For Each ws In Worksheets
If ws.Name = ShName Then
LR = ws.Range("B" & Rows.Count).End(3).Row
ws.Name = ShName
ws.Range("B" & LR + 1).Resize(x, 11) = Data.Range("B10").Resize(x, 11).Value
End If
Next
End Sub

 

test.xlsm

تم تعديل فبراير 22, 2023 بواسطه Mohamed Hicham

[أبومروان]

20 دقائق مضت, محمد عبد الناصر said:

21 دقائق مضت, محمد عبد الناصر said:

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

 

اسمح لي استاذ @Mohamed Hicham بالمشاركة مع حضرتك 

Sub SSheet()
Dim ws As Worksheet, Data As Worksheet, ShName As String
Dim LR As Long, ER As Long, x As Integer
Set Data = Sheets("المدخلات")
ShName = Data.Range("C2").Text
ER = Data.Range("B" & LR).End(xlUp).Row

If Not IsEmpty(Data.Range("B10:B20")) Then
    For x = 10 To ER
        If Data.Range("B" & x).Value = ShName Then
            Set ws = Sheets(Data.Range("C" & x).Value)
            '...rest of code
        End If
    Next x
End If
End Sub

 

[محمد عبد الناصر]

ماشاء الله بارك الله فيكم وفي علمكم وجه الله الله في ميزان حسناتكم 

[محمد هشام.]

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

[أبومروان]

42 دقائق مضت, Mohamed Hicham said:

تفضل اخي 

Sub SSheet_2()
Dim ws As Worksheet, Data As Worksheet, ShName As String
Dim LR As Long, ER As Long, x As Integer
Set Data = Sheets("المدخلات")
Dim rng As Range
ShName = Data.Range("C2").Text
ER = Data.Range("B" & Rows.Count).End(3).Row
x = ER - 7
Dim Plage As Range
Dim i As Byte
With Data
    Set Plage = Union(.Range("b10:b20"), .Range("b20"))
    For i = 1 To Plage.Count
        If Plage(i) = "" Then MsgBox ("يرجى ملا الخلية " & Plage(i).Address): Exit Sub
    Next
End With

For Each ws In Worksheets
If ws.Name = ShName Then
LR = ws.Range("B" & Rows.Count).End(3).Row
ws.Name = ShName
ws.Range("B" & LR + 1).Resize(x, 11) = Data.Range("B10").Resize(x, 11).Value
End If
Next
End Sub

 

test.xlsm 24.47 kB · 0 downlo

استاذي @Mohamed Hicham لم اجرب الكود لاني شغال من الهاتف المحمول اعذرني لو فيه خطأ