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


الرئيسية
نتائج البحث


نتائج البحث عن ردود العضو :محمود ابو الدهب
عدد النتائج (180) نتيجة
13-12-2017 10:32 مساء
icon ترحيل البيانات الموجودة بالفورم | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 طلبك صعب تحقيقة بمعادلة استاذ ادم احمد ولو تمت بمعادلة صفيف على قدر كل تلك البيانات لاثقلت الملف جدا
ولكن يمكن تنفيذها بالكود في اقل من ثانية 
جرب الكود التالى وانتظر ردك

Sub abo_dahab()
Dim Sh      As Worksheet
Dim lc      As Long
Dim lr      As Long
Dim k       As Long
Dim c       As Range
Dim  arr
'----------------------------------
Set Sh = Sheet1
lc = Sh.Cells(2, Sh.Columns.Count).End(xlToLeft).Column
lr = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
Sh.Range("a31:i" & lr + 1).ClearContents
'----------------------------------
Application.ScreenUpdating = False
For Each c In Sh.Range(Sh.Cells(1, 1), Sh.Cells(1, lc))
    If c.Value <> "" Then
          k = c.Column
          lr = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
          arr = Sh.Range(Sh.Cells(3, k), Sh.Cells(22, k + 7)).Value
          Sh.Range("a" & lr + 1).Value = c.Value
          Sh.Cells(lr, 2)(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

    End If
Next c
Erase arr
End Sub


مرفق ملف العمل معه الكود
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب


 
تقبل تحياتى وتقديرى
13-12-2017 10:06 مساء
icon المساعدة في كود ترحيل اعمدة غير متجاورة | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 تحياتى وتقديرى لشخصكم الكريم والحمد لله ان تم طلبك كما تحب 

كما انى مازلت اريد ان شاء الله من استاذ محمد الدسوقى ان يقوم بالتعديل على الكود الخاص به لارى ما الاخطاء التى وقعت فيها ونتعلم منه 
 
13-12-2017 09:30 مساء
icon تكرار اسم بشرط كتابة رقم صفه | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 اشكرك استاذ زياد والحمد لله على ان طلبك تم كما اردت
تحياتى وتقديرى
 
13-12-2017 09:24 مساء
icon تكرار اسم بشرط كتابة رقم صفه | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 اخبرتك بحدوث هذا مع الكود 
ولكن كل شي وله الف حل ان شاء الله 
الامر وما فيه هو اضافة سطر واحد للكود وسيعمل معك بامتياز ان شاء الله
التعديل هو

Private Sub CommandButton2_Click()
Dim sh As Worksheet, i As Byte, y As Integer, c As Range, c2 As Range, y2 As Integer, k As String
If TextBox1 = "" Then GoTo 100
If MsgBox("هل تريد حفظ التعديلات الحالية", vbInformation + vbMsgBoxRight + vbYesNo, "تعديل") = vbNo Then Exit Sub
Set sh = Sheets("feuil1")
     With sh

For Each c In .Range("c2:c" & .Cells(Rows.Count, 3).End(xlUp).Row)
     If c = TextBox1.Text Then
         y = c.Row
         For i = 1 To 7
         .Cells(y, i + 2).Value = Me.Controls("TextBox" & i).Value
         Next i
         For i = 1 To 6
         .Cells(y - 1, i + 3).Value = Me.Controls("TextBox" & i + 7).Value
         .Cells(y + 1, i + 3).Value = Me.Controls("TextBox" & i + 13).Value
         '================
         k = Me.Controls("textBox" & i + 13).Value
         If IsNumeric(Me.Controls("textBox" & i + 13).Value) Then
                For Each c2 In .Range("b2:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
                      If c2.Value = k Then
                            y2 = c2.Row
                            .Cells(y2, i + 3).Value = Me.Controls("textBox" & i + 1).Value
                            .Cells(y2 + 1, i + 3).Value = c.Offset(0, -1)
                      End If
                Next c2
         End If
         Next i
         '================
     End If
Next c
End With
Exit Sub
100:
MsgBox "قم أولا بإختيار الأسم الذي تود تعديله", vbExclamation + vbMsgBoxRight, "خطأ"

End Sub


منتظر ردك 


تقبل تحياتى وتقديرى
13-12-2017 08:46 مساء
icon كود لحساب رصيد الذمم | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 من خلال الرابط التالى 
ارفق صورة عن الخطأ
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
13-12-2017 08:28 مساء
icon تكرار اسم بشرط كتابة رقم صفه | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 تفضل التعديل ضع هذا الكود مكان الكود السابق في زر التعديل 

Private Sub CommandButton2_Click()
Dim sh As Worksheet, i As Byte, y As Integer, c As Range, c2 As Range, y2 As Integer, k As String
If TextBox1 = "" Then GoTo 100
If MsgBox("هل تريد حفظ التعديلات الحالية", vbInformation + vbMsgBoxRight + vbYesNo, "تعديل") = vbNo Then Exit Sub
Set sh = Sheets("feuil1")
     With sh

For Each c In .Range("c2:c" & .Cells(Rows.Count, 3).End(xlUp).Row)
     If c = TextBox1.Text Then
         y = c.Row
         For i = 1 To 7
         .Cells(y, i + 2).Value = Me.Controls("TextBox" & i).Value
         Next i
         For i = 1 To 6
         .Cells(y - 1, i + 3).Value = Me.Controls("TextBox" & i + 7).Value
         .Cells(y + 1, i + 3).Value = Me.Controls("TextBox" & i + 13).Value
         '================
         k = Me.Controls("textBox" & i + 13).Value
         If IsNumeric(Me.Controls("textBox" & i + 13).Value) Then
                For Each c2 In .Range("b2:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
                      If c2.Value = k Then
                            y2 = c2.Row
                            .Cells(y2, i + 3).Value = Me.Controls("textBox" & i + 1).Value
                      End If
                Next c2
         End If
         Next i
         '================
     End If
Next c
End With
Exit Sub


100:
MsgBox "قم أولا بإختيار الأسم الذي تود تعديله", vbExclamation + vbMsgBoxRight, "خطأ"

End Sub

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

جرب الكود ومستنى ردك 



تقبل تحياتى وتقديرى
13-12-2017 07:47 مساء
icon تكرار اسم بشرط كتابة رقم صفه | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 توضيح اكثر هل تريد تنفيذ هذا الامر بعد الضغط على زر تعديل 

وايضا هذا الامر لكل الخلايا التى تحتوى على اسم موظف ثانى
ام لبعضها 
 
13-12-2017 07:33 مساء
icon السلام عليكم - تعديل على كود ترحيل بيانات | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 تسلم 
13-12-2017 06:14 مساء
icon السلام عليكم - تعديل على كود ترحيل بيانات | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 جرب الكود التالى للترحيل بعد ما تم تعديلة اتمنى ان يكون ما ترغب به
 
Sub abo_dahab()
    Dim ws      As Worksheet
    Dim sh1     As Worksheet
    Dim sh2     As Worksheet
    Dim sh      As Worksheet
    Dim str     As String
    Dim LR      As Long
    Dim i       As Long
    Dim j       As Long
    Dim k       As Long

    Application.ScreenUpdating = False
        Set ws = Sheets("فاتورة")
        Set sh1 = Sheets("نقد")
        Set sh2 = Sheets("اقساط")
    
        str = ws.Range("C2").Value
        If str = "نقد" Then
            Set sh = sh1
        ElseIf str = "أقساط" Or str = "اقساط" Then
            Set sh = sh2
        Else
            Exit Sub
        End If
    
        LR = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
        If sh.Name = "اقساط" Then
            sh.Range("H" & LR).Value = ws.Range("B4").Value
            sh.Range("I" & LR).Value = ws.Range("B6").Value
            sh.Range("ac" & LR).Value = ws.Range("a24").Value
            sh.Range("ad" & LR).Value = ws.Range("b24").Value
            sh.Range("ae" & LR).Value = ws.Range("c24").Value
            sh.Range("af" & LR).Value = ws.Range("d24").Value
            sh.Range("ah" & LR).Value = ws.Range("e24").Value
            sh.Range("z" & LR).Value = ws.Range("a22").Value
            sh.Range("aa" & LR).Value = ws.Range("b22").Value
            sh.Range("ab" & LR).Value = ws.Range("c22").Value
            sh.Range("al" & LR).Value = ws.Range("e22").Value
            
            For j = 3 To 14
                If Not IsEmpty(ws.Cells(j, 5).Value) Then
                    sh.Cells(LR, j + k + 7).Value = ws.Cells(j, 5).Value
                    sh.Cells(LR, j + k + 8).Value = ws.Cells(j, 6).Value
                End If
                k = k + 1
            Next j
        End If
    
        For i = 16 To 20
            If ws.Cells(i, 1) = "" Then Exit For
            sh.Range("A" & LR).Resize(1, 6).Value = ws.Cells(i, 1).Resize(1, 6).Value
            sh.Range("G" & LR).Value = ws.Range("B2").Value
            sh.Range("aj" & LR).Value = ws.Range("a2").Value
            sh.Range("j" & LR).Value = ws.Range("e3").Value
            LR = LR + 1
        Next i

    
ws.Range("a2").Value = ws.Range("a2").Value + 1
ws.Range("b2,c2,a16:a20,c16:c20,d16:d20,f16:f20,e3:e14,a22:f22,a24:f24").Select
Selection.ClearContents

    Application.ScreenUpdating = True
MsgBox "Done...", 64

End Sub

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


تقبل تحياتى وتقديرى 
13-12-2017 05:38 مساء
icon المساعدة في كود ترحيل اعمدة غير متجاورة | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 كما قمت بتصميم هذا الكود لعل وعسي ان يكون ما يريد ايضا 
وارجوا ان ارى من استاذ ايمن الرد على هذا الكود ايضا

 Sub Tarheel()
Dim LR      As Long
Dim Ws      As Worksheet
Dim Sh      As Worksheet
Dim x, arr
'----------------------------------
Set Sh = Sheets("الشيت")
Set Ws = Sheets("صناعى1")
LR = Sh.Cells(Rows.Count, 7).End(xlUp).Row
'----------------------------------
Application.ScreenUpdating = False

Ws.Range("B13:I4012").ClearContents
arr = Sh.Range("a5:u" & LR + 1)

    ReDim y(1 To LR, 1 To 21)
    For x = 1 To LR - 4
        If arr(x, 10) = "صناعي1" Then
         rw = rw + 1
          y(rw, 1) = arr(x, 6)
          y(rw, 2) = arr(x, 7)
          y(rw, 7) = arr(x, 2)
        End If
     Next x

    If rw > 0 Then Ws.Cells(12, 2)(2, 1).Resize(rw, 7).Value = y()
     Erase arr
    Application.ScreenUpdating = True
End Sub


وبالنهاية تحياتى وتقديرى لكل القائمين على هذا الصرح العلمى وللجميع
 
13-12-2017 05:22 مساء
icon جمع الارقام الصحيحه والارقام العشريه كلا على حده - حسام خطاب | الكاتب :محمود ابو الدهب |المنتدى: تطبيقات محاسبيه بالاكسيل
 تقبل تحياتى واحترامى لاعمالكم الرائع التى بالفعل تفيد كل طالب علم 
بارك الله فيك
13-12-2017 05:19 مساء
icon المساعدة في كود ترحيل اعمدة غير متجاورة | الكاتب :محمود ابو الدهب |المنتدى: اكسيل اسئله واجابات
 عمل رائع رائع رائع استاذ محمد الدسوقي

ولكن عزرا  ولاننى  مقلد ولست مبدع مثل حضرتك فقد عدلة الكود الخاص به  كالتالى 

Sub AWAEL_1()
 '===========================
'ترحيل
 '==================
  Dim arr     As Variant
    Dim temp    As Variant
    Dim temp2   As Variant
    Dim cr      As Variant
    Dim cr2     As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
    Dim c2      As Long
    Dim ws As Worksheet
    Dim sh As Worksheet
Dim d  As Long
d = MsgBox("هـــل تـريـد ترحيل قوائم الامتحان العملي لطلاب مجال الصناعى1 حقــاً", vbYesNo, "تحذير")
If d = vbYes Then

    Set ws = Sheets("الشيت")
    Set sh = Sheets("صناعى1")
    '= = = = = = = = = = = =
    ' الشيت الهدف المطلوبة مسح البيانات القديمة
    sh.Range("B13:I4012").ClearContents
    ' تحديد اخر صف به بيانات في الشيت المصدر
    lr = ws.Cells(Rows.Count, 7).End(xlUp).Row
    'متغير مصفوفة البيانات ومدى البيانات بها
    arr = ws.Range("A5:V" & lr).Value
    ' مصفوفة النتائج
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    ReDim temp2(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    'ارقام الاعمدة المطلوب نسخها
      cr = Array(6, 7)
      cr2 = Array(2)
    j = 1
    For i = LBound(arr, 1) To UBound(arr, 1)
    '==================
   ' المعيار اوالشرط ورقم عمود الترحيل
If arr(i, 10) = "صناعي1" Then
    '==================
            temp(j, 1) = j
            For c = LBound(cr) To UBound(cr)
                temp(j, c + 1) = arr(i, cr(c))
            Next c
            For c2 = LBound(cr2) To UBound(cr2)
                temp2(j, c2 + 1) = arr(i, cr2(c2))
            Next c2
            j = j + 1
    '==================
    End If
    '==================
    Next i
    With sh
    'خلية بداية اللصق في الشيت الهدف
        .Range("b13").Resize(j, UBound(temp, 2)).Value = temp
        .Range("h13").Resize(j, UBound(temp2, 2)).Value = temp2
    End With
    ' تفريغ المصفوفة
  Erase arr
  Erase temp
  Erase temp2
Else
If d = vbNo Then
End If
End If
End Sub



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

فتحياتى وتقدير واجلالى لشخصكم الكريم استاذ محمد الدسوقى وكم انتظر رد حضرتك باشتياق

الصفحة 1 من 15 < 1 2 3 4 15 > الأخيرة »





الساعة الآن 08:29 صباحا