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

اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا




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

Preview

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


نتائج البحث عن ردود العضو :salim
عدد النتائج (695) نتيجة
28-10-2020 06:04 مساء
icon ادراج صف جديد بشرط | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 كان من الواجب وضع ملف للعمل عليه
جرب هذا الماكرو على الملف النموذج الذي انشأته لك

Option Explicit
Sub Insert_rows()
Dim Ro%, i%

del_empty_Rows
With Sheets("Salim")
    Ro = .Cells(Rows.Count, 1).End(3).Row
    i = 1
    Do Until i > Ro
         If .Cells(i, 1) <> .Cells(i + 1, 1) Then
            Ro = Ro + 1
            .Cells(i + 1, 1).EntireRow.Insert
            i = i + 1
        End If
      i = i + 1
    Loop
End With
End Sub
'+++++++++++++++++++++++++++++++++++
Sub del_empty_Rows()
With Sheets("Salim")
    Dim Lst%
        On Error Resume Next
          Lst = .Cells(Rows.Count, 1).End(3).Row
          .Range("A1:A" & Lst).SpecialCells(4).Delete
        On Error GoTo 0
    End With
End Sub

الملف مرفق
24-10-2020 07:21 صباحا
icon وضع الشرطه المائله بشرط | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 تم التعديل

Option Explicit
'+++++++++++++++++++++++++++++++++++
Sub DeleteShapes()
Dim L, T, W, H
L = 980: T = 10: W = 210: H = 66
If ActiveSheet.Shapes.Count > 0 Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
End If
'+++++++++++++++++++++++++++

ActiveSheet.Buttons.Add(L, T, W, H).Select
  With Selection
   .OnAction = "SLASHH_Total"
   .Characters.Text = "Run"
    With .Characters(1, 3).Font
     .Size = 36
     .ColorIndex = 3
     .Bold = True
    End With
  End With
  End Sub

'+++++++++++++++++++++++++++
Sub DrawSlash(headerRange As Range, DataRange As Range)
 
    Dim shp         As Shape
    Dim c           As Range
    Const d         As Byte = 15

  For Each c In headerRange
      If Application. _
      CountA(DataRange.Columns(c.Column - DataRange.Column + 1)) > 0 Then
         With ActiveSheet.Shapes _
          .AddLine(c.Left + d, c.Top + d, _
           c.Left + c.Width - d, c.Top + c.Height * 2 - d).Line
           .ForeColor.RGB = vbRed
          .Weight = 5
        End With
      End If
  Next c
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub SLASHH_Total()
    Dim ws          As Worksheet
    Dim m           As Long
    Dim i           As Long
  DeleteShapes
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("sheet_mostgad")
        m = ws.Cells(Rows.Count, "C").End(xlUp).Row + 3
     
  For i = 5 To m Step 4
    If ws.Range("AY" & i + 2).Font.ColorIndex = 3 And _
       ws.Range("AY" & i + 2) <> "" Then
       DrawSlash ws.Range("AY" & i + 1), ws.Range("AY" & i + 2)
    End If
   Next i
    Application.ScreenUpdating = True
End Sub

 
24-10-2020 12:02 صباحا
icon وضع الشرطه المائله بشرط | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 Try This macro

Option Explicit
Sub DeleteTextBoxes()
Dim L, T, W, H
L = 980: T = 10: W = 210: H = 66
If ActiveSheet.Shapes.Count > 0 Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
End If
'+++++++++++++++++++++++++++

ActiveSheet.Buttons.Add(L, T, W, H).Select
  With Selection
   .OnAction = "SLASHH_Total"
   .Characters.Text = "Run"
    With .Characters(1, 3).Font
     .Size = 36
     .ColorIndex = 3
     .Bold = True
    End With
  End With
  End Sub

'+++++++++++++++++++++++++++
Sub DrawSlash(headerRange As Range, DataRange As Range)
 
    Dim shp         As Shape
    Dim c           As Range
    Const d         As Integer = 15

  For Each c In headerRange
      If Application. _
      CountA(DataRange.Columns(c.Column - DataRange.Column + 1)) > 0 Then
        With ActiveSheet.Shapes _
          .AddLine(c.Left + d, c.Top + d, _
           c.Left + c.Width - d, c.Top + c.Height - d).Line
          .ForeColor.RGB = RGB(255, 0, 0)
          .Weight = 4.55
        End With
      End If
  Next c
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub SLASHH_Total()
    Dim ws          As Worksheet
    Dim oRng        As Range
    Dim m           As Long
    Dim i           As Long
  DeleteTextBoxes
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("sheet_mostgad")
        m = ws.Cells(Rows.Count, "C").End(xlUp).Row + 3
     
  For i = 5 To m Step 4
    DrawSlash ws.Range("AY" & i & ":AY" & i), _
    ws.Range("AY" & i + 1 & ":AY" & i + 2)
   Next i
    
   If Not oRng Is Nothing Then _
    oRng.Interior.Color = RGB(208, 206, 206)
    Application.ScreenUpdating = True
End Sub

 
23-10-2020 05:15 صباحا
icon احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 للمرة الألف
لا أحد يعمل على جداول فارغة
قليل فقط من البيانات( 10-15 صف) تكفي لمعرفة ماذا تريد
18-10-2020 06:33 مساء
icon طباعة تقرير من الفورم وترحيل بيانات بالكامل من ListBox الي الشيت | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 ممكن اذا اردت ان نعمل نفس الشيء بالمعادلات
ولا حاجة لليوزر ومشاكله
انظر  الى   Sheet Salim  من هذا الملف

 
18-10-2020 05:50 مساء
icon طباعة تقرير من الفورم وترحيل بيانات بالكامل من ListBox الي الشيت | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 تم تصحيح الكود
يجب تغيير اسماء الــ Lebels
LB_2 /  LB_1   وهكذا  حتى الـــ  22  dk2Pk_Form1


 
18-10-2020 03:02 مساء
icon طباعة تقرير من الفورم وترحيل بيانات بالكامل من ListBox الي الشيت | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 جرب هذا الملف
اضغط على الزر لنقل البيانات الى الشيت 1
Cdm7c_User_1
الملف مرفق
 
16-10-2020 09:32 مساء
icon قوائم فصول | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 كود الطباعة
للطباعة استبدل
SH2.PrintPreview (الذي يظهر معاينة قبل الطباعة)
بالسطر
SH2.PrintOut   (الذي برسل الورقة الى  الطباعة مباشرة)

Sub Print_Me()
  Dim LBMx%, LF%, LB%
LF = SH2.Cells(Rows.Count, "F").End(3).Row + 1
LB = SH2.Cells(Rows.Count, "B").End(3).Row

LBMx = Application.Max(SH2.Range("B2:B49")) + 6
SH2.Range("B6:B" & LF).EntireRow.Hidden = False
SH2.Range("B" & LBMx).Resize(LF - 3 - LBMx).EntireRow.Hidden = True
SH2.PageSetup.PrintArea = SH2.Range("B1:H" & LF).Address
SH2.PrintPreview
End Sub


 
16-10-2020 07:09 مساء
icon قوائم فصول | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 للمرة الألف
فصل الجدول عن الخلايا التي لا شأن له بها بأعمدة وصفوف فارغة و عدم دمج الخلايا داخل الجدول وذلك كي يعمل الماكرو بشكل صحيح
هذا ينطبق على الصفحتين

Option Explicit

Sub My_filter()
Dim Rg_M As Range, Rg_S As Range
Dim Cret As Range
Dim LM%, LS%
LM = Main.Cells(Rows.Count, 4).End(3).Row

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

If LM < 5 Then GoTo Bay_Bay
Set Rg_M = Main.Range("D5:J" & LM)
Set Rg_S = SH2.Range("D6").CurrentRegion
Rg_S.ClearContents
SH2.Range("B6:B49").ClearContents
Set Cret = SH2.Range("E2")
SH2.Range("B6:b49").EntireRow.Hidden = False
Rg_M.AutoFilter 4, Cret
Main.Range("D6:D" & LM).SpecialCells(12).Copy
SH2.Range("D6").PasteSpecial (12)


Main.Range("H6:H" & LM).SpecialCells(12).Copy
SH2.Range("E6").PasteSpecial (12)


Main.Range("J6:J" & LM).SpecialCells(12).Copy
SH2.Range("F6").PasteSpecial (12)


Main.Range("I6:I" & LM).SpecialCells(12).Copy
SH2.Range("G6").PasteSpecial (12)


If Main.AutoFilterMode Then
 Main.Range("D5").AutoFilter
End If
LS = SH2.Range("D6").CurrentRegion.Rows.Count

SH2.Range("B6").Resize(LS).Value = _
Evaluate("Row(1:" & LS & ")")
SH2.Range("B6:b49").SpecialCells(4).EntireRow.Hidden = True
SH2.Range("B6").Select
Bay_Bay:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

الملف مرفق
16-10-2020 06:51 صباحا
icon مطلوب مساعدة استدعاء بيانات من 3 جداول بدالة انديكس وماتش | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 [quote=Lendo]
ريما تقصد هذه المعادلة

=IFERROR(
        IFERROR(INDEX('08'!$A$1:$A$1000,MATCH(A2,'08'!$A$1:$A$1000,0),1),
       INDEX('11'!$A$1:$A$1000,MATCH(A2,'11'!$B$1:$B$1000,0),1)),
       INDEX('12'!$A$1:$A$1000,MATCH(A2,'12'!$A$1:$A$1000,0),1))

 

16-10-2020 05:34 صباحا
icon مطلوب مساعدة استدعاء بيانات من 3 جداول بدالة انديكس وماتش | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 ربما كان المقصود هذا الشيء
 
09-10-2020 10:36 صباحا
icon احتاج كود ترحيل مبلغ الى عدد 7 شيتس | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 بارك الله فيك استاذ  ali mohamed ali
مشكور جداااااااااااااااا حفظك الله

تأكد ان الصف رقم 2 في الشيت Itm  غير فارغ

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





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

أعلن هنا
أعلن هنا
أعلن هنا