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

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




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

Preview

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


نتائج البحث عن ردود العضو :salim
عدد النتائج (769) نتيجة
17-04-2021 09:56 مساء
icon نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 استبدل الكود بهذا

Option Explicit

Sub without_zeros()
Dim Source_Array As Variant
Dim Target_Array()
Dim n%, i%
    With Sheets("ورقة1")
       Source_Array = .Range("K3").CurrentRegion
      .Range("D3").Resize(UBound(Source_Array), 2).Clear
       For i = 1 To UBound(Source_Array)
          If Source_Array(i, 1) <> 0 Then
             n = n + 1
             ReDim Preserve Target_Array(1 To 2, 1 To n)
             Target_Array(1, n) = Source_Array(i, 1)
             Target_Array(2, n) = Source_Array(i, 2)
           End If
        Next i
          
          If n Then
            .Range("D3").Resize(n, 2) = _
             Application.Transpose(Target_Array)
                 
           .Range("K3").CurrentRegion.Copy
           .Range("D3").Resize(n, 2).PasteSpecial 4
           Application.CutCopyMode = False
          .Range("D3").Select
       End If
    End With
End Sub

الملف مرفق
 
17-04-2021 06:56 صباحا
icon نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 زيادة في اثراء الموضوع

Option Explicit

Sub without_zeros()
Dim Source_Array As Variant
Dim Target_Array()
Dim n%, i%
    With Sheets("ورقة1")
      .Range("D3").CurrentRegion.ClearContents
       Source_Array = .Range("K3").CurrentRegion
       
       For i = 1 To UBound(Source_Array)
          If Source_Array(i, 1) <> 0 Then
             n = n + 1
             ReDim Preserve Target_Array(1 To 2, 1 To n)
             Target_Array(1, n) = Source_Array(i, 1)
             Target_Array(2, n) = Source_Array(i, 2)
           End If
        Next i
          
          If n Then
            .Range("D3").Resize(n, 2) = _
             Application.Transpose(Target_Array)
          End If
    End With
End Sub
16-04-2021 09:31 صباحا
icon كود لحماية المصنف و الشير vba | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 Try This Macro

Option Explicit

Sub ProtectWorkbook()
 
    Dim My_Workbook As Workbook
    Dim File_Pas As String
    Dim Struc_Pas As String
 
    Set My_Workbook = Application.ActiveWorkbook
 
    File_Pas = "123"     'Change Here as you like
    Struc_Pas = "ABC"    'Change Here as you like
 
    My_Workbook.ProtectSharing Password:=File_Pas, _
        SharingPassword:=Struc_Pas
 
End Sub

14-04-2021 05:50 مساء
icon مساعده في مؤثرات شهرية | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 ربما يكون ما تريده
تم نغيير المعادلات في الصفحة (Salim) للحصول على كل ايام الشهر بغض النظر اذا كان 28 /29/ 30 / او 31 يوم



Option Explicit

Sub Find_Ijasat()
Dim D As Worksheet, S As Worksheet
Dim Rod%, Ros%, I%, x%, k%
Dim Rg_FD As Range
Dim Rg_Code As Range


Set D = Sheets("Data"): Set S = Sheets("Salim")
Rod = D.Cells(Rows.Count, 2).End(3).Row
Ros = S.Cells(Rows.Count, 2).End(3).Row
D.Range("B3").Resize(Rod, 8).Interior.ColorIndex = xlNone
Set Rg_FD = D.Range("B3:B" & Rod)
If Ros < 6 Then Exit Sub
 S.Range("D6").Resize(Ros - 5, 31).ClearContents
For I = 6 To Ros
    Set Rg_Code = Rg_FD.Find(S.Cells(I, 2), Lookat:=1)
    If Rg_Code Is Nothing Then GoTo Find_Again
        x = Rg_Code.Row

         For k = 4 To 35
            If S.Cells(4, k) = D.Cells(x, 4) Then
               S.Cells(I, k) = D.Cells(x, 7)
               D.Range("B" & x).Resize(, 8).Interior.ColorIndex = 35
               Exit For
            End If
        Next k
Find_Again:
Next I
End Sub

الملف مرفق من جديد
 
14-04-2021 10:05 صباحا
icon مساعده في مؤثرات شهرية | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 يعني حضرتك اكتب شهر فبراير واضغط run مش هيظهر اي نتائج ....[/quote]
لاحظ الصورة وقل اين الخطأ   (الملف من جديد مرفق)
DYs6a_Screenshot_1
13-04-2021 03:10 مساء
icon مساعده في مؤثرات شهرية | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 لم أفهم شيئاً مما تريد !!!
13-04-2021 11:52 صباحا
icon مساعده في مؤثرات شهرية | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 جرب هذا الكود (صفحة  Salim )

Option Explicit

Sub Find_Ijasat()
Dim D As Worksheet, S As Worksheet
Dim Rod%, Ros%, I%, x%, k%
Dim Rg_FD As Range
Dim Rg_Code As Range


Set D = Sheets("Data"): Set S = Sheets("Salim")
Rod = D.Cells(Rows.Count, 2).End(3).Row
Ros = S.Cells(Rows.Count, 2).End(3).Row
Set Rg_FD = D.Range("B3:B" & Rod)
If Ros < 6 Then Exit Sub
 S.Range("D6").Resize(Ros - 5, 31).ClearContents
For I = 6 To Ros
    Set Rg_Code = Rg_FD.Find(S.Cells(I, 2), Lookat:=1)
    If Rg_Code Is Nothing Then GoTo Find_Again
        x = Rg_Code.Row
         For k = 4 To 35
            If S.Cells(4, k) = D.Cells(x, 4) Then
               S.Cells(I, k) = D.Cells(x, 7)
               Exit For
            End If
        Next k
Find_Again:
Next I
End Sub


الملف مرفق
06-04-2021 05:21 صباحا
icon التحقق بين خليتين بين ملفين اكسيل | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 لمعرفة مسار اي ملف تريده

1- افتح الملف
2- اكتب هذه المعادلة داخله ( في اي صفحة   اي خلية تريد)

=LEFT(CELL("filename",A1),FIND("[",CELL("filename",A1))-2)

 
04-04-2021 07:45 صباحا
icon التحقق بين خليتين بين ملفين اكسيل | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 و من اين لي ان أعرف مسار الملف الثاني كي اضعه في الكود؟؟؟
03-04-2021 06:37 صباحا
icon الترحيل من اليوزرفورم الى شيت الاكسل | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 وهل على من يريد المساعدة ان ينشأ ملفاً يحتوي على ما تريد ؟؟؟
الكود

Option Explicit

  Private Sub But_Check_Click()
 If Me.TextBox1 = "" Or Me.TextBox1 = "" Then Exit Sub
 
 Dim Ro%, Sh As Worksheet, i%
 Dim Bol As Boolean
 
 Set Sh = Sheets("Sheet1")
 Ro = Sh.Cells(Rows.Count, 1).End(3).Row
 If Ro = 1 Then
  Ro = 2
  Sh.Cells(Ro, 1) = Me.TextBox1
  Sh.Cells(Ro, 2) = Me.TextBox2
  Exit Sub
 End If
  i = 2
  Do Until i = Ro + 1
      If UCase(Me.TextBox1) & "*" & UCase(Me.TextBox2) = _
       UCase(Sh.Cells(i, 1)) & "*" & UCase(Sh.Cells(i, 2)) Then
       Bol = True
       MsgBox "This Values are Already Exsit" & Chr(10) & _
       "In: " & Sh.Cells(i, 1).Resize(, 2).Address
        Exit Sub
      End If
     i = i + 1
   Loop

  If Not Bol Then
   Sh.Cells(Ro + 1, 1) = Me.TextBox1
   Sh.Cells(Ro + 1, 2) = Me.TextBox2
  End If
 End Sub

الملف مرفق
03-04-2021 05:22 صباحا
icon التحقق بين خليتين بين ملفين اكسيل | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 هذا الكود


Sub Compaire_cells()
Dim My_Formula
Dim Pth$

Pth = ThisWorkbook.Path & "\[2.xlsm]Sheet1'!$D$10"

My_Formula = "=E5='" & Pth

Range("MM1").Formula = My_Formula
If Range("MM1") = True Then
    MsgBox "E5 in " & ActiveSheet.Name & "=" & Chr(10) & _
    "Workbook 2.xlsm /Sheet1'!$D$10"
 Else
    MsgBox " Not Match"
End If

Range("MM1").Clear
End Sub

31-03-2021 09:18 مساء
icon تعديل مكرو الترحيل | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 jtYSo_Nourمازالت الاصناف موجوده بالفاتورة 
قلت لك ما تفعل لحذف القديم
لتفريغ الخلايا التي لا تحتوي معادلات قم بازالة الفاصلة العليا من امام
          هذا السطر    'Fix_Rg.ClearContents

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





الساعة الآن 12:54 صباحا

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