أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





اذا كانت خانة العمود D فارغة اريد الترحيل يتم للصف الذى يليه

الاساتذة الاخوة المحترمين ملفى هذا هو ملف من تصميم الاستاذ الكريم استاذ سليم ملف ممتاز ويعمل بامتياز احتاج تعديل وهو فى ..


موضوع مغلق


13-08-2020 09:32 مساء
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 

الاساتذة الاخوة المحترمين ملفى هذا هو ملف من تصميم الاستاذ الكريم استاذ سليم
ملف ممتاز ويعمل بامتياز احتاج تعديل 
وهو فى حالة بدأ من السطر الرابع اذاكانت كل البيانات كاملة عدا المبلغ حاليا يقوم الكود بترحيل البيانات 
اريد الكود ان ينتقل للسطر المكتمل ولا يرحل الا السطر الكامل اما الذى ينقصه المبلغ فقط فقط المبلغ يقوم الكود بالانتقال للصف الذى يليه ويكون فيه رقم فى عمود المبلغ
الكود الان تمام اذا ان هناك بيان ناقص تخرج رسالة توقف الترحيل وتخرج رسالة وهو تمام اريده كما هو بس فقط فقط عمود المبلغ اذا كان فارغ يستمر الترحيل دون ترحيل الصف الذى به 
خانة العمود d فارغة

Sub Salim_Code()
    Dim TR As Worksheet, Sh As Worksheet
    Dim Find_Range
    Dim Frst As Range, Third As Range
    Dim Sixth As Range
    Dim My_rg As Range
    Dim Ro1%, ro%, col%, Last_Ro%
    Dim nEW_RO%, nEW_COL%
    Dim Answer As Byte
    Dim arr(), m%

    Set TR = Sheets("transfer")
ro = TR.Cells(Rows.Count, 2).End(3).Row
 If ro = 1 Then MsgBox "No data To Transfer": Exit Sub
If ro < 4 Then Exit Sub
    Set Frst = TR.Range("A2")
    Set Third = TR.Range("C2")
    Set Sixth = TR.Range("F2")
    Set My_rg = TR.Range("B4:E" & ro)
If Frst = "" Or Third = "" Or Sixth = "" Then _
 MsgBox "Verify the First Row Please": Exit Sub
 
For Ro1 = 1 To My_rg.Columns(1).Cells.Count
If My_rg.Cells(Ro1, 4) = vbNullString Then
 MsgBox "Sorry Your cell " & My_rg.Cells(Ro1, 4).Address & Chr(10) & "Is Empty" & Chr(10) & _
  "I Can Not continue"
 Exit Sub
End If
Next
 '//////////////////////////////////////
 For Ro1 = 1 To Sheets.Count
  If UCase(Mid(Sheets(Ro1).Name, 1, 3)) <> "SH_" Then
   GoTo MY_Next
  End If
 Set Find_Range = Sheets(Ro1).Range("C:C").Find(Third, lookat:=1)
  If Not Find_Range Is Nothing Then
   ReDim Preserve arr(m)
   arr(m) = Sheets(Ro1).Name
   m = m + 1
  End If
MY_Next:
Next
  If m <> 0 Then
     MsgBox "This Invoice is Already Exit in Sheets: " & Chr(10) & _
     Join(arr, " ; ")
    Exit Sub
  End If

  '///////////////////////////////////////
'++++++++++++++++++++++++++++++++++++++++++++++++
 For Ro1 = 1 To My_rg.Columns(1).Cells.Count
  Set Sh = Sheets(My_rg.Cells(Ro1, 4) & "")

  '+++++++++++++++++++++++++++++++++++++++++++
  col = Sh.Range("A1:MM1").Find(Sixth, lookat:=1).Column
   Last_Ro = Sh.Cells(Rows.Count, 2).End(3).Row + 1
   If Last_Ro = 2 Then Last_Ro = 3
     Sh.Cells(Last_Ro, 1) = Frst.Value
     Sh.Cells(Last_Ro, 2) = My_rg.Cells(Ro1, 1)
     Sh.Cells(Last_Ro, 3) = Third
     My_rg.Cells(Ro1, 2) = Third
     Sh.Cells(Last_Ro, col) = My_rg.Cells(Ro1, 3)
Next_Ro1:
Next
 '++++++++++++++++++++++++++++++++++++++++
For i = 1 To Sheets.Count
  If UCase(Mid(Sheets(i).Name, 1, 3)) = "SH_" Then
   nEW_RO = Sheets(i).Cells(Rows.Count, 2).End(3).Row
  If nEW_RO = 1 Then GoTo next_Item
  nEW_COL = Sheets(i).Cells(1, Columns.Count).End(1).Column
   With Sheets(i).Range("A3").Resize(nEW_RO - 2, nEW_COL)
    .ClearFormats
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 16
    .InsertIndent 1
    .Interior.ColorIndex = 35
    .Columns(1).NumberFormat = "d/ m /yyyy"
   End With
  End If
next_Item:
Next i
Application.EnableEvents = False
TR.Select
Answer = MsgBox(" Do You Want To Delete" & Chr(10) & _
 "the Data In Then The Sheet" & Chr(10) & _
 """" & TR.Name & """", 36)
  If Answer = 6 Then
  CLEAR_ME
  End If
 Application.EnableEvents = True
 
End Sub

كل الدعاء من القلب والشكر والامتنان 
اختكم
 
 
  MrSALIM KING.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(38.948) KB



أفضل إجابة مقدمة من salim وهي:
الماكرو المطلوب

Sub Salim_Code()
    Dim TR As Worksheet, Sh As Worksheet
    Dim Find_Range
    Dim Frst As Range, Third As Range
    Dim Sixth As Range
    Dim My_rg As Range
    Dim Ro1%, ro%, col%, Last_Ro%
    Dim nEW_RO%, nEW_COL%
    Dim Answer As Byte
    Dim arr(), m%

    Set TR = Sheets("transfer")
ro = TR.Cells(Rows.Count, 2).End(3).Row
 If ro = 1 Then MsgBox "No data To Transfer": Exit Sub
If ro < 4 Then Exit Sub
    Set Frst = TR.Range("A2")
    Set Third = TR.Range("C2")
    Set Sixth = TR.Range("F2")
    Set My_rg = TR.Range("B4:E" & ro)
If Frst = "" Or Third = "" Or Sixth = "" Then _
 MsgBox "Verify the First Row Please": Exit Sub
 
For Ro1 = 1 To My_rg.Columns(1).Cells.Count
If My_rg.Cells(Ro1, 4) = vbNullString Then
 MsgBox "Sorry Your cell " & My_rg.Cells(Ro1, 4).Address & Chr(10) & "Is Empty" & Chr(10) & _
  "I Can Not continue"
 Exit Sub
End If
Next
 '//////////////////////////////////////
 For Ro1 = 1 To Sheets.Count
  If UCase(Mid(Sheets(Ro1).Name, 1, 3)) <> "SH_" Then
   GoTo MY_Next
  End If
 Set Find_Range = Sheets(Ro1).Range("C:C").Find(Third, lookat:=1)
 
  If Not Find_Range Is Nothing Then
   ReDim Preserve arr(m)
   arr(m) = Sheets(Ro1).Name
   m = m + 1
  End If
MY_Next:
Next
  If m <> 0 Then
     MsgBox "This Invoice is Already Exit in Sheets: " & Chr(10) & _
     Join(arr, " ; ")
    Exit Sub
  End If

  '///////////////////////////////////////
'++++++++++++++++++++++++++++++++++++++++++++++++
 For Ro1 = 1 To My_rg.Columns(1).Cells.Count
  Set Sh = Sheets(My_rg.Cells(Ro1, 4) & "")
  If My_rg.Cells(Ro1, 3) = vbNullString Then
      MsgBox "ألخلية (" & My_rg.Cells(Ro1, 3).Address(0, 0) & ")" & _
      " في الورقة " & """" & TR.Name & """" & " فارغة" & Chr(10) & _
      "سأتجاوز هذا الأمر", vbMsgBoxRtlReading
      GoTo Next_Ro1
  End If
  '+++++++++++++++++++++++++++++++++++++++++++
  col = Sh.Range("A1:MM1").Find(Sixth, lookat:=1).Column
   Last_Ro = Sh.Cells(Rows.Count, 2).End(3).Row + 1
   If Last_Ro = 2 Then Last_Ro = 3
     Sh.Cells(Last_Ro, 1) = Frst.Value
     Sh.Cells(Last_Ro, 2) = My_rg.Cells(Ro1, 1)
     Sh.Cells(Last_Ro, 3) = Third
     My_rg.Cells(Ro1, 2) = Third
     Sh.Cells(Last_Ro, col) = My_rg.Cells(Ro1, 3)
Next_Ro1:
Next
 '++++++++++++++++++++++++++++++++++++++++
For i = 1 To Sheets.Count
  If UCase(Mid(Sheets(i).Name, 1, 3)) = "SH_" Then
   nEW_RO = Sheets(i).Cells(Rows.Count, 2).End(3).Row
  If nEW_RO = 1 Then GoTo next_Item
  nEW_COL = Sheets(i).Cells(1, Columns.Count).End(1).Column
   With Sheets(i).Range("A3").Resize(nEW_RO - 2, nEW_COL)
    .ClearFormats
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 16
    .InsertIndent 1
    .Interior.ColorIndex = 35
    .Columns(1).NumberFormat = "d/ m /yyyy"
   End With
  End If
next_Item:
Next i
Application.EnableEvents = False
TR.Select
Answer = MsgBox(" Do You Want To Delete" & Chr(10) & _
 "the Data In Then The Sheet" & Chr(10) & _
 """" & TR.Name & """", 36)
  If Answer = 6 Then
  CLEAR_ME
  End If
 Application.EnableEvents = True
 
End Sub
'====================================
Sub CLEAR_ME()
Dim My_sheet As Worksheet
Dim t%
Set My_sheet = Sheets("transfer")
With My_sheet
  t = .Cells(Rows.Count, 2).End(3).Row
  .Range("A4:E" & t).ClearContents
  .Range("A2").ClearContents
  .Range("C2").ClearContents
   .Range("F2").ClearContents
 End With
End Sub


 
عرض الإجابة




17-08-2020 06:21 صباحا
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif اذا كانت خانة العمود D فارغة اريد الترحيل يتم للصف الذى يليه
الماكرو المطلوب

Sub Salim_Code()
    Dim TR As Worksheet, Sh As Worksheet
    Dim Find_Range
    Dim Frst As Range, Third As Range
    Dim Sixth As Range
    Dim My_rg As Range
    Dim Ro1%, ro%, col%, Last_Ro%
    Dim nEW_RO%, nEW_COL%
    Dim Answer As Byte
    Dim arr(), m%

    Set TR = Sheets("transfer")
ro = TR.Cells(Rows.Count, 2).End(3).Row
 If ro = 1 Then MsgBox "No data To Transfer": Exit Sub
If ro < 4 Then Exit Sub
    Set Frst = TR.Range("A2")
    Set Third = TR.Range("C2")
    Set Sixth = TR.Range("F2")
    Set My_rg = TR.Range("B4:E" & ro)
If Frst = "" Or Third = "" Or Sixth = "" Then _
 MsgBox "Verify the First Row Please": Exit Sub
 
For Ro1 = 1 To My_rg.Columns(1).Cells.Count
If My_rg.Cells(Ro1, 4) = vbNullString Then
 MsgBox "Sorry Your cell " & My_rg.Cells(Ro1, 4).Address & Chr(10) & "Is Empty" & Chr(10) & _
  "I Can Not continue"
 Exit Sub
End If
Next
 '//////////////////////////////////////
 For Ro1 = 1 To Sheets.Count
  If UCase(Mid(Sheets(Ro1).Name, 1, 3)) <> "SH_" Then
   GoTo MY_Next
  End If
 Set Find_Range = Sheets(Ro1).Range("C:C").Find(Third, lookat:=1)
 
  If Not Find_Range Is Nothing Then
   ReDim Preserve arr(m)
   arr(m) = Sheets(Ro1).Name
   m = m + 1
  End If
MY_Next:
Next
  If m <> 0 Then
     MsgBox "This Invoice is Already Exit in Sheets: " & Chr(10) & _
     Join(arr, " ; ")
    Exit Sub
  End If

  '///////////////////////////////////////
'++++++++++++++++++++++++++++++++++++++++++++++++
 For Ro1 = 1 To My_rg.Columns(1).Cells.Count
  Set Sh = Sheets(My_rg.Cells(Ro1, 4) & "")
  If My_rg.Cells(Ro1, 3) = vbNullString Then
      MsgBox "ألخلية (" & My_rg.Cells(Ro1, 3).Address(0, 0) & ")" & _
      " في الورقة " & """" & TR.Name & """" & " فارغة" & Chr(10) & _
      "سأتجاوز هذا الأمر", vbMsgBoxRtlReading
      GoTo Next_Ro1
  End If
  '+++++++++++++++++++++++++++++++++++++++++++
  col = Sh.Range("A1:MM1").Find(Sixth, lookat:=1).Column
   Last_Ro = Sh.Cells(Rows.Count, 2).End(3).Row + 1
   If Last_Ro = 2 Then Last_Ro = 3
     Sh.Cells(Last_Ro, 1) = Frst.Value
     Sh.Cells(Last_Ro, 2) = My_rg.Cells(Ro1, 1)
     Sh.Cells(Last_Ro, 3) = Third
     My_rg.Cells(Ro1, 2) = Third
     Sh.Cells(Last_Ro, col) = My_rg.Cells(Ro1, 3)
Next_Ro1:
Next
 '++++++++++++++++++++++++++++++++++++++++
For i = 1 To Sheets.Count
  If UCase(Mid(Sheets(i).Name, 1, 3)) = "SH_" Then
   nEW_RO = Sheets(i).Cells(Rows.Count, 2).End(3).Row
  If nEW_RO = 1 Then GoTo next_Item
  nEW_COL = Sheets(i).Cells(1, Columns.Count).End(1).Column
   With Sheets(i).Range("A3").Resize(nEW_RO - 2, nEW_COL)
    .ClearFormats
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 16
    .InsertIndent 1
    .Interior.ColorIndex = 35
    .Columns(1).NumberFormat = "d/ m /yyyy"
   End With
  End If
next_Item:
Next i
Application.EnableEvents = False
TR.Select
Answer = MsgBox(" Do You Want To Delete" & Chr(10) & _
 "the Data In Then The Sheet" & Chr(10) & _
 """" & TR.Name & """", 36)
  If Answer = 6 Then
  CLEAR_ME
  End If
 Application.EnableEvents = True
 
End Sub
'====================================
Sub CLEAR_ME()
Dim My_sheet As Worksheet
Dim t%
Set My_sheet = Sheets("transfer")
With My_sheet
  t = .Cells(Rows.Count, 2).End(3).Row
  .Range("A4:E" & t).ClearContents
  .Range("A2").ClearContents
  .Range("C2").ClearContents
   .Range("F2").ClearContents
 End With
End Sub


 
 
 
  Mr_SALIM KING.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(47.862) KB


17-08-2020 08:38 مساء
مشاهدة مشاركة منفردة [2]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif اذا كانت خانة العمود D فارغة اريد الترحيل يتم للصف الذى يليه
حضرتك لايصدق ما تستطيع عمله بالاكسيل رائع رائع رائع رائع
تسلم وتعيش يارب
اكثر الله خيرك وزادك من فضله اخى سليم ملك الاكسيل شاكرة فضلك اخى



الكلمات الدلالية
كانت ، خانة ، العمود ، فارغة ، اريد ، الترحيل ، للصف ، الذى ، يليه ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 03:13 صباحا