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

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


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





تعديل على كود ترحيل بدون فراغات

السلام عليكم دا كود ترحيل بيانات من شيت لشيت اخر مشكلتة انه بيرحل الخلايا الفارغه بردو ووضعت الشرط ولكنه مش شغال علما ب ..


موضوع مغلق


21-12-2020 05:22 مساء
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 

السلام عليكم
دا كود ترحيل بيانات من شيت لشيت اخر
مشكلتة انه بيرحل الخلايا الفارغه بردو 
ووضعت الشرط ولكنه مش شغال
علما بان اول خلية بها صنف هى
b12
 

Sub Macro1()
Sheet2.Activate
Dim r As Integer
Dim xnewr As Integer
For r = 12 To 30
If IsEmpty(Cells(r, 8)) Then Exit Sub
xnewr = Sheet4.Cells(1, 1).CurrentRegion.Rows.Count + 1
Sheet4.Cells(xnewr, 1) = Cells(7, 3)
Sheet4.Cells(xnewr, 2) = Cells(7, 8)
Sheet4.Cells(xnewr, 3) = Cells(10, 4)
Sheet4.Cells(xnewr, 4) = Cells(r, 2)
Sheet4.Cells(xnewr, 5) = Cells(r, 6)
Sheet4.Cells(xnewr, 6) = Cells(r, 1)
Sheet4.Cells(xnewr, 7) = Cells(r, 7)
Sheet4.Cells(xnewr, 8) = Cells(r, 8)
Sheet4.Cells(xnewr, 9) = Cells(r, 10)
Sheet4.Cells(xnewr, 10) = Cells(r, 11)
Sheet4.Cells(xnewr, 11) = Cells(r, 12)
Sheet4.Cells(xnewr, 12) = Cells(r, 13)
Next
End Sub
رحيل يتم بدون فراغات
عذرا انا معرفتش اكتب الكود فى مربع اخر لانى معرفش يتعمل ازاى


 


أفضل إجابة مقدمة من salim وهي:
الملف ثقيل و بطيء لأنّك تستعمل  Shapes لا عمل لها
جرب هذا الكود

Option Explicit
Sub translete_data()
Dim M As Worksheet
Dim F As Worksheet
Dim RO%, x%

Set M = Sheets("Main")
Set F = Sheets("Fatura")
RO = F.Cells(Rows.Count, "E").End(3).Row + 1
If M.Range("D11") = Empty Then Exit Sub

With F
      .Cells(RO, 2) = Format(M.Range("D8"), "dd/mm/yyyy hh:mm")
      .Cells(RO, 3) = M.Range("H7")
      .Cells(RO, 4) = M.Range("D11")
      
      x = 13
      
      Do Until M.Cells(x, "B") = vbNullString
               With F.Cells(RO, 5)
                 .Value = M.Cells(x, "B")
                 .Offset(, 1) = M.Cells(x, "F")
                 .Offset(, 2) = M.Cells(x, "G")
                 .Offset(, 3) = M.Cells(x, "H")
               End With
          RO = RO + 1: x = x + 1
       Loop
       
    With F.Range("A2:A" & RO - 1)
       .Formula = "=IF(B2="""","""",MAX($A$1:A1)+1)"
       .Value = .Value
    End With
End With
End Sub

الملف مرفق
 
عرض الإجابة




21-12-2020 07:19 مساء
مشاهدة مشاركة منفردة [1]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 793
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 10
قوة السمعة : 3910
عدد الإجابات: 108
 offline 
look/images/icons/i1.gif تعديل على كود ترحيل بدون فراغات
وعليكم السلام ورحمة الله وبركاته 
عدل

Then Exit Sub

الى 

Then goto nextm

وقبل next 
اعمل سطر واكتب فيه nextm

21-12-2020 09:52 مساء
مشاهدة مشاركة منفردة [2]
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 
look/images/icons/i1.gif تعديل على كود ترحيل بدون فراغات
هذا هو الملف





 
 
  ثابت - Copy.xlsm   تحميل xlsm مرات التحميل :(6)
الحجم :(430.823) KB


22-12-2020 04:41 صباحا
مشاهدة مشاركة منفردة [3]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 793
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 10
قوة السمعة : 3910
عدد الإجابات: 108
 offline 
look/images/icons/i1.gif تعديل على كود ترحيل بدون فراغات


Sub Macro1()

Sheet2.Activate

Dim r As Integer

Dim xnewr As Integer

For r = 12 To 30

If IsEmpty(Cells(r, 8)) Then goto nextm
xnewr = Sheet4.Cells(1, 1).CurrentRegion.Rows.Count + 1

Sheet4.Cells(xnewr, 1) = Cells(7, 3)

Sheet4.Cells(xnewr, 2) = Cells(7, 8)

Sheet4.Cells(xnewr, 3) = Cells(10, 4)

Sheet4.Cells(xnewr, 4) = Cells(r, 2)

Sheet4.Cells(xnewr, 5) = Cells(r, 6)

Sheet4.Cells(xnewr, 6) = Cells(r, 1)

Sheet4.Cells(xnewr, 7) = Cells(r, 7)

Sheet4.Cells(xnewr, 8) = Cells(r, 8)

Sheet4.Cells(xnewr, 9) = Cells(r, 10)

Sheet4.Cells(xnewr, 10) = Cells(r, 11)

Sheet4.Cells(xnewr, 11) = Cells(r, 12)

Sheet4.Cells(xnewr, 12) = Cells(r, 13)

Nextm
Next

End Sub




22-12-2020 02:01 مساء
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif تعديل على كود ترحيل بدون فراغات
الملف ثقيل و بطيء لأنّك تستعمل  Shapes لا عمل لها
جرب هذا الكود

Option Explicit
Sub translete_data()
Dim M As Worksheet
Dim F As Worksheet
Dim RO%, x%

Set M = Sheets("Main")
Set F = Sheets("Fatura")
RO = F.Cells(Rows.Count, "E").End(3).Row + 1
If M.Range("D11") = Empty Then Exit Sub

With F
      .Cells(RO, 2) = Format(M.Range("D8"), "dd/mm/yyyy hh:mm")
      .Cells(RO, 3) = M.Range("H7")
      .Cells(RO, 4) = M.Range("D11")
      
      x = 13
      
      Do Until M.Cells(x, "B") = vbNullString
               With F.Cells(RO, 5)
                 .Value = M.Cells(x, "B")
                 .Offset(, 1) = M.Cells(x, "F")
                 .Offset(, 2) = M.Cells(x, "G")
                 .Offset(, 3) = M.Cells(x, "H")
               End With
          RO = RO + 1: x = x + 1
       Loop
       
    With F.Range("A2:A" & RO - 1)
       .Formula = "=IF(B2="""","""",MAX($A$1:A1)+1)"
       .Value = .Value
    End With
End With
End Sub

الملف مرفق
 
 
 
  Fatura.xlsm   تحميل xlsm مرات التحميل :(8)
الحجم :(383.861) KB


22-12-2020 05:42 مساء
مشاهدة مشاركة منفردة [5]
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 
look/images/icons/i1.gif تعديل على كود ترحيل بدون فراغات
السلام عليكم
جزاك الله كل خير اخى وحبيبى سليم
والف شكر على تعديلك للكود
واود ان اضيف معلومة تعاملت معها قبل ان ارى الكود الخاص بك
جعلت الترحيل لدى اقل من اللحظة    ودا من اللى اتعلمناه من حضراتكم طبعا
ولكن لتعم الفائدة لمن هم قليلين الخبرة مثلى
انا عملت ماكر بجعل حساب المعادلات يدوى ثم كود الترحيل ثم ماكرو اخر بجعل حساب المعادلات اوتوماتيكيا
او باختصار    هنحط كود الترحيل بين الكودين دول

Application.CutCopyMode = False
    Application.Calculation = xlManual
end sub
Application.Calculation = xlAutomatic
 

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








الكلمات الدلالية
تعديل ، بسيط ، ترحيل ،


 










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

الساعة الآن 10:36 صباحا