1- مجرد النظر الى الملف من ناحية زركشة الألوان الفاقعة تجعل من

          يريد المساعدة ينفر من ذلك

2- لا احد يعمل مع جداول فارغة 

لذلك نضيحة كي تلقي المساعدة:

1- تنسيقات عادية للخلايا

2- املأ الجداول (10 الى 15 صف في كل منها) ببيانات عشوائية

 

 جرب هذا الكود



Option Explicit

Sub trans_data()

Const mot$ = "DELIVERED"

Dim Source_Sheet As Worksheet

Dim Target_Sheet As Worksheet

Dim Rs_Copy As Range, Cel As Range

Dim dic As Object, ky

Dim Rs%, n%, Rt%

Dim arr As Variant



Set Source_Sheet = Sheets("ONGOING")

Set Target_Sheet = Sheets("DELIVERED")

Set dic = CreateObject("Scripting.Dictionary")

Set Rs_Copy = Source_Sheet.Range("a2").CurrentRegion

Rs = Rs_Copy.Rows.Count

Rt = Target_Sheet.Cells(Rows.Count, 1).End(3).Row + 1

If Rt = 2 Then Rt = 3

If Rs = 1 Then Exit Sub

Set Rs_Copy = Rs_Copy.Offset(1).Resize(Rs - 1)

For Each Cel In Rs_Copy.Columns(15).Cells

 If UCase(Cel) = mot Then

 n = n + 1

   arr = Application.Transpose(Cel.Offset(, -13).Resize(, 15))

   arr = Join(Application.Transpose(arr), "*")

   dic(n) = arr

 End If

 Next

 If dic.Count Then

    For Each ky In dic.keys

      Target_Sheet.Cells(Rt, 1) = ky

      Target_Sheet.Cells(Rt, 2).Resize(, 15) = _

       Split(dic(ky), "*")

      Target_Sheet.Cells(Rt, "Q") = Date

      Rt = Rt + 1

    Next

 End If

 

End Sub



الملف مرفق

 لا أعلم اذا كان هذا ما تريده



Private Sub Cmd_Clera_Click()

Me.ListBox1.Clear

End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++



Private Sub CommandButton1_Click()

 For I = 1 To 9

 Me.Controls("TextBox" & I) = _

  Chr(Application.RandBetween(65, 90)) & " " & _

  Chr(Application.RandBetween(65, 90))

 Next

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++



Private Sub ADD_To_shett_Click()

If Me.ListBox1.ListCount = 0 Then Exit Sub

Dim z%

 With Sheets("sheet1")

 z = .Cells(Rows.Count, 1).End(3).Row + 1

   .Cells(z, 1).Resize(ListBox1.ListCount, 9).Value = _

    ListBox1.List

 End With

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub ADD_To_list_Click()

Dim n As Byte, t, k%

For t = 1 To 9

 If Me.Controls("TextBox" & t) <> vbNullString Then

 k = k + 1

End If

Next

 If k Then

With Me.ListBox1

   .AddItem

     For n = 0 To .ColumnCount - 1

    .List(.ListCount - 1, n) = _

     Me.Controls("TextBox" & n + 1)

    Next

   End With

 End If

End Sub





الملف مرفق

 جرب هذا الماكرو (يقوم باخفاء الصفوف وليس حذفها)

        (اذا كنت تريد الحذف يمكن التعديل)



Sub My_Macro()



Dim LASTROW

Dim Rg As Range

Dim Impt

Dim Sh As Worksheet

Set Sh = Sheets("ElectronicPayment")

Show_ALL



LASTROW = Sh.Cells(Rows.Count, 1).End(3).Row



Impt = Application.InputBox("Put an Number <= " & LASTROW _

       , 1, Type:=1)

  If Val(Impt) <= 0 Or CInt(Impt) > LASTROW Then

   MsgBox "You must type Only number<=  " & LASTROW

   Exit Sub

  

  End If

  Impt = Int(Impt)

 Set Rg = Sh.Range("A" & Impt).Resize(LASTROW - Impt + 1, 7)

 Rg.EntireRow.Hidden = True

 

End Sub

'+++++++++++++++++++++++++++++++++++++++

Sub Show_ALL()

Sheets("ElectronicPayment").Rows.Hidden = False

End Sub



الملف مرفق

 كنت قد وضعت موضوعاً جول الــServer لهذا المنتدي و انه في أغلب الأحيان 70% تظهر هذه العبارة على الــBrowser
 This site can’t be reached  والان النسبة اصبحت 90%

ولاحياة لمن تنادي   اي لم يرد على تساؤلاتي من المسؤولين عن الموقع
 لهذا اذا استمر هذا الوضع سأقوم (آسفاً) بتعليق عضويتي في الموقع
 

الكود من جديد (الصفحات الباقية ليست محذوفة بل تم اخفاءها

لمراقبة عمل الكود)



Sub My_Data()



Dim A, D    As Worksheet

Dim RD%, RA%, I%, K%

Dim Ar_A(), Ar_D()

Set A = Sheets("Atten")

Set D = Sheets("Daily ENT")

RD = D.Range("D7").Resize(500).Find("", LookIn:=xlValues).Row - 1

RA = A.Cells(Rows.Count, "D").End(3).Row + 1

If RA < 7 Then RA = 7

'-----------------------------------------------------

 Ar_A = Array("D", "E")

 Ar_D = Array("D", "C")



For K = 7 To RD

   For I = 0 To 1

      A.Cells(RA, Ar_A(I)) = _

      D.Cells(K, Ar_D(I))

   Next I

     A.Cells(RA, I + 4).Resize(, 7).Value = _

   D.Cells(K, "F").Resize(, 7).Value

 RA = RA + 1

Next K

End Sub



 

 جرب هذا الكود



Sub My_Data()



Dim N, D    As Worksheet

Dim RD%, RN%, I%, K%

Dim Ar_N(), Ar_D()



Set N = Sheets("New")

Set D = Sheets("Data")



RD = D.Cells(Rows.Count, "C").End(3).Row

RN = N.Cells(Rows.Count, "D").End(3).Row + 1

If RN < 7 Then RN = 7

'-----------------------------------------------------

 Ar_N = Array("D", "E")

 Ar_D = Array("D", "C")



For K = 7 To RD

   For I = 0 To 1

      N.Cells(RN, Ar_N(I)) = _

      D.Cells(K, Ar_D(I))

   Next I

  

   N.Cells(RN, I + 4).Resize(, 7).Value = _

   D.Cells(K, "F").Resize(, 7).Value

 RN = RN + 1

Next K



End Sub





الملف مرفق

 

 جرب هذا الكود

يحدد لك عدد المصنفات المفنوحة ما عدا المصنف الرئيسي

و يفترض ان  الملف المصدر ( المراد النسخ منه ) هو أول واحد منها



Option Explicit



Sub How_Many_Opened_Books()

Dim P%, Other_Path$

Dim Coll As New Collection

Dim Main_Book As Workbook

Dim Other_Book As Workbook

    

    For P = 1 To Application.Workbooks.Count

     If Workbooks(P).Name <> ThisWorkbook.Name Then

       Coll.Add Workbooks(P).Name

     End If

    Next

 

 If Coll.Count = 0 Then Exit Sub

    Set Main_Book = ThisWorkbook

    Set Other_Book = Workbooks(Coll(1))

    MsgBox Other_Book.Name

    Other_Path = Other_Book.Path

    MsgBox Other_Path

End Sub


 

 

 Application.Visible = False

هذه العبارة خطيرة جداً لانها تخفي الExcel بالكامل ولا تخفي الورقة كما تعتقد

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

اذن انت هنا تخفي الـــ Application التي هي الــ Excel فكيف تطلب الطباعة

 Try This code



Option Explicit

Sub fin_min()

Dim arr(), m, i, Mn

    For i = 2 To 7

      If Cells(i, 1) < Cells(2, 3) Then

        ReDim Preserve arr(m)

        arr(m) = Cells(i, 1)

        m = m + 1

      End If

    Next

If m > 0 Then

    Mn = Application.Min(Application.Max(arr), Cells(2, 3))

    MsgBox Range("a2:a7").Find(Mn, lookat:=1).Address

End If

End Sub

 جرب هذا الملف
 

 Try This Code



Option Explicit

Sub Hide_then_Print()

Dim LR%

 

 With Sheets("موازنة 2020")

   LR = .Cells(Rows.Count, 1).End(3).Row

  .Rows("1:3").Hidden = False

  .PageSetup.PrintArea = _

  .Range("A1:F" & LR).Address

  

  .PrintPreview             ' <<<==== Change to .PrintOut

  

  .Rows("1:3").Hidden = True

  End With

End Sub

 this Formula



=SUMPRODUCT(($D$11:$D$38<=$F$3)*G$11:G$38)