اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

ابا اسماعيل

03 عضو مميز
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    271

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    1

 نوع المحتوي 

مشاركات المكتوبه بواسطه ابا اسماعيل

    المساعدة فى تصحيح اخطاء كود vba

    في منتدى الاكسيل Excel

    قام بنشر

    جرب هذا الكود 

    
Private Sub CommandButton1_Click()
    Dim WB As Workbook
    Dim SH As Worksheet
    Dim SH2 As Worksheet
    Dim SH3 As Worksheet
    Dim SH4 As Worksheet
    Dim LR As Long, LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, LR5 As Long, LR6 As Long
    Dim i As Long, Q As Long, U As Long
    Dim X As Long, N As Long, T As Long
    Dim DataArray() As Variant ' مصفوفة لتخزين البيانات مؤقتًا

    Set WB = ThisWorkbook
    Set SH = WB.Sheets("CUT")
    Set SH2 = WB.Sheets("POLISH")
    Set SH3 = WB.Sheets("AR_ST")
    Set SH4 = WB.Sheets("AR_PAID")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' تنظيف ورقة SH3
    SH3.Range("B4:M" & SH3.Rows.Count).ClearContents

    ' حساب آخر صفوف البيانات في كل ورقة
    LR = SH.Cells(SH.Rows.Count, "D").End(xlUp).Row
    LR1 = SH3.Cells(SH3.Rows.Count, "B").End(xlUp).Row + 1
    LR2 = SH2.Cells(SH2.Rows.Count, "E").End(xlUp).Row
    LR5 = SH4.Cells(SH4.Rows.Count, "B").End(xlUp).Row

    ' تخزين البيانات في مصفوفة
    ReDim DataArray(1 To LR - 3, 1 To 6)
    X = 1
    For i = 4 To LR
        If SH3.Cells(2, "B") = SH.Cells(i, "D") And SH.Cells(i, "AC") <> "0" Then
            DataArray(X, 1) = SH.Cells(i, "O")
            DataArray(X, 2) = SH.Cells(i, "F")
            DataArray(X, 3) = SH.Cells(i, "G")
            DataArray(X, 4) = SH.Cells(i, "P")
            DataArray(X, 5) = SH.Cells(i, "AC")
            X = X + 1
        End If
    Next i

    ' كتابة البيانات في ورقة SH3
    SH3.Range("B" & LR1).Resize(X - 1, 5).Value = DataArray
    N = LR1 + X - 1

    ' تخزين البيانات من SH2 في مصفوفة
    ReDim DataArray(1 To LR2 - 3, 1 To 6)
    X = 1
    For Q = 4 To LR2
        If SH3.Cells(2, "B") = SH2.Cells(Q, "E") Then
            DataArray(X, 1) = SH2.Cells(Q, "B")
            DataArray(X, 2) = SH2.Cells(Q, "C")
            DataArray(X, 3) = SH2.Cells(Q, "D")
            DataArray(X, 4) = SH2.Cells(Q, "G")
            DataArray(X, 5) = SH2.Cells(Q, "L")
            DataArray(X, 6) = SH2.Cells(Q, "P")
            X = X + 1
        End If
    Next Q

    ' كتابة البيانات في ورقة SH3
    SH3.Range("B" & N).Resize(X - 1, 6).Value = DataArray
    T = N + X - 1

    ' تخزين البيانات من SH4 في مصفوفة
    ReDim DataArray(1 To LR5 - 3, 1 To 2)
    X = 1
    For U = 4 To LR5
        If SH3.Cells(2, "B") = SH4.Cells(U, "C") Then
            DataArray(X, 1) = SH4.Cells(U, "B")
            DataArray(X, 2) = SH4.Cells(U, "F")
            X = X + 1
        End If
    Next U

    ' كتابة البيانات في ورقة SH3
    SH3.Range("B" & T).Resize(X - 1, 2).Value = DataArray

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

     

     

    • Like 2

    مطلوب استبدال الكود بكود اسرع VBA

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه ابا اسماعيل

    جريب هذا الكود

      

    Sub FasterMacro()
    Dim wsSource As Worksheet
    Dim wsCriteria As Worksheet
    Dim wsExtract As Worksheet
    Dim sourceRange As Range
    Dim criteriaRange As Range
    Dim extractRange As Range
    
    ' تحديد ورقة المصدر
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقتك
    
    ' تحديد ورقة المعايير
    Set wsCriteria = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر
    
    ' تحديد ورقة الاستخراج
    Set wsExtract = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر
    
    ' تحديد نطاق البيانات المصدر
    Set sourceRange = wsSource.Range("AM:BD")
    
    ' تحديد نطاق المعايير
    Set criteriaRange = wsCriteria.Range("'Criteria'")
    
    ' تحديد نطاق الاستخراج
    Set extractRange = wsExtract.Range("'Extract'")
    
    ' تطبيق تصفية متقدمة
    sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaRange, CopyToRange:=extractRange, Unique:=False
    
    ' تحديد نطاق آخر (يمكن تعديله وفقًا لاحتياجاتك)
    wsSource.Range("DC3:DT3").Select
End Sub

     

    • Like 2

    الغاء الفلتر من الملف

    في منتدى الاكسيل Excel

    قام بنشر

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

      

    Private Sub CommandButton2_Click()
    With Worksheets("التكويد").Range("A1:T1")
        ' إلغاء الفلتر إذا كان مفعلاً
        If ActiveSheet.AutoFilterMode Then
            ActiveSheet.AutoFilterMode = False
        End If

        If Me.ComboBox1.Text = "" Then Exit Sub

        ' تنفيذ عملية التصفية
        .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text
    End With

    ' استدعاء الطباعة
    Call CommandButton1_Click

    ' إلغاء الفلتر بعد الطباعة
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
End Sub

     

    كيف أتأكد أنه لايوجد خلايا مكررة؟

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه ابا اسماعيل

    بعد اذن الاخ أبوأحـمـد

    جرب هذا الكود سيقوم بالتحقق من وجود القيم المكررة في الأعمدة A و B و C وسيقوم بسحب القيم المكررة إلى الأسفل

      

    Private Sub RemoveDuplicatesAndFillDown()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim colRangeA As Range
    Dim colRangeB As Range
    Dim colRangeC As Range
    Dim cell As Range

    ' تعيين الورقة المستهدفة
    Set ws = ThisWorkbook.Worksheets("التكويد")
    
    ' العثور على آخر صف غير فارغ في العمود C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' تعيين نطاقات الأعمدة A و B و C
    Set colRangeA = ws.Range("A2:A" & lastRow)
    Set colRangeB = ws.Range("B2:B" & lastRow)
    Set colRangeC = ws.Range("C2:C" & lastRow)
    
    ' إلغاء تنسيق الخلايا المحددة
    colRangeA.NumberFormat = "General"
    colRangeB.NumberFormat = "General"
    colRangeC.NumberFormat = "General"
    
    ' إزالة القيم المكررة وسحب القيم إلى الأسفل في الأعمدة A و B
    For Each cell In colRangeA
        If Application.WorksheetFunction.CountIf(colRangeA, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
    
    For Each cell In colRangeB
        If Application.WorksheetFunction.CountIf(colRangeB, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
    
    For Each cell In colRangeC
        If Application.WorksheetFunction.CountIf(colRangeC, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
End Sub

     

    • Like 1

    الغاء الفلتر من الملف

    في منتدى الاكسيل Excel

    قام بنشر

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

      

    Private Sub CommandButton1_Click()
    ' ... الأكواد الحالية ...

    ' عرض نافذة الطباعة
    Application.Dialogs(xlDialogPrint).Show

    ' إلغاء عملية التصفية بعد الطباعة
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
End Sub

     

     

    تغيير حجم الخط حسب عدد الكلمات في الخليه

    في منتدى الاكسيل Excel

    قام بنشر

    تفظل جريب هذا الكود

      

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim cell As Range

    Set ws = ThisWorkbook.Sheets("Sheet1")

    If Not Intersect(Target, ws.Columns("A")) Is Nothing Then
        Application.EnableEvents = False

        For Each cell In Target
            If cell.Value <> "" Then
                Dim charCount As Long
                charCount = Len(cell.Value) - Len(Replace(cell.Value, " ", ""))

                Dim fontSize As Long
                fontSize = 14 - charCount

                If fontSize < 8 Then
                    fontSize = 8
                End If

                cell.Font.Size = fontSize
            End If
        Next cell

        Application.EnableEvents = True
    End If
End Sub

     

    • Like 2

    تغيير حجم الخط حسب عدد الكلمات في الخليه

    في منتدى الاكسيل Excel

    قام بنشر

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

    تفضل

    قوم بتحديث البيانات في العمود اول مرة عند تضع الكود

     

     

      

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim cell As Range

    
    Set ws = ThisWorkbook.Sheets("Sheet1")

    '
    If Not Intersect(Target, ws.Columns("A")) Is Nothing Then
        Application.EnableEvents = False

       ص
        For Each cell In Target
            If cell.Value <> "" Then
                
                Dim wordCount As Long
                wordCount = Len(cell.Value) - Len(Replace(cell.Value, " ", "")) + 1

                
                If wordCount = 1 Then
                    cell.Font.Size = 14
                ElseIf wordCount = 2 Then
                    cell.Font.Size = 14 '
                ElseIf wordCount >= 3 Then
                    cell.Font.Size = 14
                End If

                cell.Font.Bold = True
                cell.Font.Name = "Arial"
            End If
        Next cell

        Application.EnableEvents = True '
    End If
End Sub

     

    • Like 1

    اضافة اكواد لبرنامج

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه ابا اسماعيل

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

      

    Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address = "$J$5" Then
        
        If Not IsEmpty(Target.Value) Then
            
            Dim wsData As Worksheet
            Set wsData = ThisWorkbook.Sheets("البيانات")
            Dim searchRange As Range
            Dim foundCell As Range

            Set searchRange = wsData.Range("A:A")
            Set foundCell = searchRange.Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole)


            If Not foundCell Is Nothing Then
                Dim rowNum As Long
                rowNum = foundCell.Row
                Dim dataRange As Range
                Set dataRange = wsData.Range("A" & rowNum & ":R" & rowNum)
                
 
                Dim wsSource As Worksheet
                Set wsSource = ThisWorkbook.Sheets("الرئيسية")
                
                Dim targetRange As Range
                Set targetRange = wsSource.Range("K7:K24")
                targetRange.Value = Application.Transpose(dataRange.Value)
            Else
               
                wsSource.Range("K7:K24").Value = ""
            End If
        Else
          
            wsSource.Range("K7:K24").Value = ""
        End If
    End If
End Sub

     

    اضافة اكواد لبرنامج

    في منتدى الاكسيل Excel

    قام بنشر

    جرب الكود التالي 

    Private Sub CommandButton1_Click()
  
    Dim sourceValues() As Variant
    sourceValues = Array("C8", "C10", "C12", "C14", "C16", "C18", "F8", "F10", "F12", "F14", "F16", "F18", "I8", "I10", "I12", "I14", "I16", "I18 ")

    
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("الرئيسية")

   
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets("البيانات")

    
    Dim lastRow As Long
    lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row

   
    Dim searchRange As Range
    Set searchRange = wsTarget.Range("A2:A" & lastRow)
    Dim foundRow As Range
    Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole)

    If foundRow Is Nothing Then
      
        For i = 0 To UBound(sourceValues)
            wsSource.Range(sourceValues(i)).Copy wsTarget.Cells(lastRow + 1, i + 1)
        Next i
    Else
        
        For i = 0 To UBound(sourceValues)
            wsTarget.Cells(foundRow.Row, i + 1).Value = wsSource.Range(sourceValues(i)).Value
        Next i
    End If
End Sub

     

    اضافة اكواد لبرنامج

    في منتدى الاكسيل Excel

    قام بنشر

    ¨

    جرب الكود التالي لعله المطلوب  الخاص بي ترحيل

     

      

    Private Sub CommandButton1_Click()
    ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáÃÕáíÉ
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("الرئسية")

    ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáåÏÝ
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets("البيانات")

    ' ÊÑÍíá ÇáÈíÇäÇÊ
    Dim lastRow As Long
    lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim searchRange As Range
    Set searchRange = wsTarget.Range("A2:A" & lastRow) ' äØÇÞ ÇáÈÍË Ýí ÇáÕÝÍÉ ÇáåÏÝ

    If Application.WorksheetFunction.CountIf(searchRange, wsSource.Range("C8").Value) = 0 Then
        ' äÓÎ ÑÞã ÇáãÚÇãáÉ ÅÐÇ áã íÊã ÇáÚËæÑ Úáíå Ýí ÇáÕÝÍÉ ÇáåÏÝ
        wsSource.Range("C8").Copy wsTarget.Cells(lastRow + 1, 1)
        wsSource.Range("C10").Copy wsTarget.Cells(lastRow + 1, 2)
        wsSource.Range("C12").Copy wsTarget.Cells(lastRow + 1, 3)
        wsSource.Range("C14").Copy wsTarget.Cells(lastRow + 1, 4)
        wsSource.Range("C16").Copy wsTarget.Cells(lastRow + 1, 5)
        wsSource.Range("C18").Copy wsTarget.Cells(lastRow + 1, 6)
          wsSource.Range("F8").Copy wsTarget.Cells(lastRow + 1, 7)
        wsSource.Range("F10").Copy wsTarget.Cells(lastRow + 1, 8)
        wsSource.Range("F12").Copy wsTarget.Cells(lastRow + 1, 9)
        wsSource.Range("F14").Copy wsTarget.Cells(lastRow + 1, 10)
        wsSource.Range("F16").Copy wsTarget.Cells(lastRow + 1, 11)
        wsSource.Range("F18").Copy wsTarget.Cells(lastRow + 1, 12)
        
          wsSource.Range("I8").Copy wsTarget.Cells(lastRow + 1, 7)
        wsSource.Range("I10").Copy wsTarget.Cells(lastRow + 1, 8)
        wsSource.Range("I12").Copy wsTarget.Cells(lastRow + 1, 9)
        wsSource.Range("I14").Copy wsTarget.Cells(lastRow + 1, 10)
        wsSource.Range("I16").Copy wsTarget.Cells(lastRow + 1, 11)
        wsSource.Range("I18").Copy wsTarget.Cells(lastRow + 1, 12)
        
        
    Else
        ' ÇÓÊÈÏÇá ÇáÈíÇäÇÊ ÅÐÇ Êã ÇáÚËæÑ Úáì ÑÞã ÇáãÚÇãáÉ ãæÌæÏðÇ ÈÇáÝÚá Ýí ÇáÕÝÍÉ ÇáåÏÝ
        Dim foundRow As Range
        Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole)

        If Not foundRow Is Nothing Then
            wsTarget.Cells(foundRow.Row, 2).Value = wsSource.Range("C10").Value
            wsTarget.Cells(foundRow.Row, 3).Value = wsSource.Range("C12").Value
            wsTarget.Cells(foundRow.Row, 4).Value = wsSource.Range("C14").Value
            wsTarget.Cells(foundRow.Row, 5).Value = wsSource.Range("C16").Value
            wsTarget.Cells(foundRow.Row, 6).Value = wsSource.Range("C18").Value
             
             wsTarget.Cells(foundRow.Row, 7).Value = wsSource.Range("F10").Value
            wsTarget.Cells(foundRow.Row, 8).Value = wsSource.Range("F12").Value
            wsTarget.Cells(foundRow.Row, 9).Value = wsSource.Range("F14").Value
            wsTarget.Cells(foundRow.Row, 10).Value = wsSource.Range("F16").Value
            wsTarget.Cells(foundRow.Row, 11).Value = wsSource.Range("F18").Value
            
             wsTarget.Cells(foundRow.Row, 12).Value = wsSource.Range("I8").Value
             
            wsTarget.Cells(foundRow.Row, 13).Value = wsSource.Range("I10").Value
            wsTarget.Cells(foundRow.Row, 14).Value = wsSource.Range("I12").Value
            wsTarget.Cells(foundRow.Row, 15).Value = wsSource.Range("I14").Value
            wsTarget.Cells(foundRow.Row, 16).Value = wsSource.Range("I16").Value
            
        End If
    End If

End Sub

     

    مساعدة في ملف قرعة شهر

    في منتدى الاكسيل Excel

    قام بنشر

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

    ارجو المساعدة

    نحن مجموعة من الشباب (20) شخص نجمع في كل شهر مبلغ 100 دينار لكل شخص، قومنا بعمل قرعة بيننا على من يأخذ مبلغ 2000 دينار، من يأخذ في شهر الاول وفي شهر الثاني وفي شهر الثالث وهكدا حتى اخير وحد ، وطبعاً يستمر في الدفع حتى تكتمل المجموعة وبعد أن يتحصل كل الشباب على نصيبهم وتكتمل المجموعة، وذلك لا يتم إلا بعد 20 أشهر قومت بعمل قائمة من الاسماء الشباب في ملف اكسيل

    اريد طريقة في كل 4  من شهر يتم نسخ اسم شخص المستفيد من عمود C الى عمود D وشهر في عمود  E

    ويتم وضع لون على سطر شخص المستفيد

    اريد تطبيق طريقة كما في سطر ٣

     

     

    القرعة.xlsm

    طلب اريد في كل شهريتم ادراج اسم الشخص تلقائي من عمود اخر

    في منتدى الاكسيل Excel

    قام بنشر

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

     المشكلة في المعاداة يوم 10 في شهر يتم نسخ جميع الأسماء تلقائي من عمود A الى عمود  C 

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

    قوم بتغير تاريخ الجهاز وتما نسخ جميع الأسماء كما في صورة

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

    55.PNG

    طلب اريد في كل شهريتم ادراج اسم الشخص تلقائي من عمود اخر

    في منتدى الاكسيل Excel

    قام بنشر

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

    اريد طريقة في كل شهر يوم 10 في شهريتم ادراج اسم الشخص تلقائي من عمود A الى عمود  C  وادخال التاريخ بشكل تلقائي  في عمود D تاريخ التحصيل

    تاريخ التحصيل.xlsm

    طلب تعديل كود بحت الاخ الكبير salim ليتوفق مع كود الليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر

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

    اخي رجاء وليس امرا لو سمحت ممكن ان تقوم بتعديل الكود البحت ليتوافق مع كود الليست بوكس الاول في الملف وجزاك الله خيرا اخي الفاضل

    طلب تعديل كود بحت الاخ الكبير salim ليتوفق مع كود الليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم اخي سليم حاصبيا جزاك الله خيرا على اهتمامك بالموضوع

    اخي سليم ممكن لوسمحت تعديل الكود ليتوفق  مع كود اللست بوكس دوناالغاء كود ليست بوكس

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

×
×
  • اضف...

Important Information

  I accept