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

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




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


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


نتائج البحث عن ردود العضو :salim
عدد النتائج (259) نتيجة
22-04-2019 11:20 صباحا
icon اريد توزيع نقود كما بالبنك | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 
تم معالجة الامر بواسطة الكود

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Amount#, i%
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
If Target.Address = "$B$2" Then
Amount = Round(Range("B2"), 2)
Target = Amount
Range("B5:B16").Value = ""
For i = 5 To 16
Do While Amount >= Cells(i, 1).Value
Cells(i, 2).Value = Cells(i, 2).Value + 1
Amount = Amount - Cells(i, 1).Value
Loop
Next
End If
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

سأحاول وضع معادلات بهذا الشأن
الملف مرفق


20-04-2019 12:15 مساء
icon سؤال احتاج كود يقوم بكتابة تاريخ اليوم فى خلية بناءا على اذا كانت الخلية المقابة غير فارغة | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 Try this Macro

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("e2:e" & Rows.Count)) Is Nothing And _
Target.Count = 1 Then
Target.Offset(, -1) = IIf(Target.Offset(, -1) <> vbNullString, _
Target.Offset(, -1), Date + Time)
End If
Application.EnableEvents = True
End Sub

file Included
14-04-2019 01:37 مساء
icon ترحيل عن طريق check box | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 
المشاركة الأصلية كتبت بواسطة:khaled alborene
 استاذ سليم هل استبدل الكودين بهذا الكود الجديد

نعم
الكود الأول والثاني

14-04-2019 07:51 صباحا
icon ترحيل عن طريق check box | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 استبدل الكودين الى هذه

Sub copy_data()
Dim chk As CheckBox
Dim r, lrow As Single
lrow = Sheets("محصل").Range("b" & Rows.Count).End(xlUp).Row + 1
For Each chk In ActiveSheet.CheckBoxes
If chk = 1 Then
r = chk.TopLeftCell.Row
Sheets("محصل").Range("b" & lrow).Resize(, 7).Value = _
ActiveSheet.Cells(r, 2).Resize(, 7).Value
lrow = lrow + 1
chk.Delete
Rows(r).Delete
End If

Next chk

End Sub
'=================================

Sub ADD_CHECK_BOXS()
If ActiveSheet.Name <> "My sheet" Then Exit Sub
Dim cell, lrow As Single
Dim xleft, xtop, xwidth, xhieght As Double
Application.ScreenUpdating = False
ActiveSheet.CheckBoxes.Delete

lrow = ActiveSheet.Range("b" & Rows.Count).End(xlUp).Row
For cell = 3 To lrow
If Cells(cell, "b").Value <> "" Then
xtop = Cells(cell, "a").Top '36
ActiveSheet.CheckBoxes.Add(15, xtop, 10, 15).Select
With Selection
.Caption = ""
.Value = xlOff
.LinkedCell = _
.TopLeftCell.Address
End With
End If
Next cell
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub


الملف من جديد
11-04-2019 08:36 مساء
icon ترحيل عن طريق check box | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 الماكرو الأول لتعبئة البوكسات المطلوب 

Sub ADD_CHECK_BOXS()
If ActiveSheet.Name <> "My sheet" Then Exit Sub
Dim cell, lrow As Single
Dim xleft, xtop, xwidth, xhieght As Double
Application.ScreenUpdating = False
ActiveSheet.CheckBoxes.Delete

lrow = ActiveSheet.Range("b" & Rows.Count).End(xlUp).Row
For cell = 3 To lrow
If Cells(cell, "b").Value <> "" Then
xtop = Cells(cell, "a").Top '36
ActiveSheet.CheckBoxes.Add(15, xtop, 10, 15).Select
With Selection
.Caption = ""
.Value = xlOff
.LinkedCell = _
.TopLeftCell.Offset(0, 3000).Address
End With
End If
Next cell

Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

الماكرو الثاني للترحيل

Sub copy_data()
Dim chk As CheckBox
Dim r, lrow As Single
lrow = Sheets("محصل").Range("b" & Rows.Count).End(xlUp).Row + 1
For Each chk In ActiveSheet.CheckBoxes
If chk = 1 Then
r = chk.TopLeftCell.Offset(0, 0).Row
Sheets("محصل").Range("b" & lrow).Resize(, 7).Value = _
ActiveSheet.Cells(r, 2).Resize(, 7).Value
lrow = lrow + 1
chk.Delete
End If

Next chk

End Sub
 
الملف مرفق


07-04-2019 09:52 مساء
icon تلوين خلايا بشرط | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 

تمت معالجة الموضوع


الكود


Option Explicit
Sub colorize_table()
Application.ScreenUpdating = False
Dim Find_Rg As Range, r%, i%
Dim serch_range As Range
Set serch_range = Sheets("المعطيات").Range("R3:S12")
Dim start_rg As Range
Dim last_ro%: last_ro = Sheets("data2").Cells(Rows.Count, 2).End(3).Row
Dim k%
For k = 9 To 18 Step 2
Cells(6, k).Resize(last_ro - 4).Interior.ColorIndex = 40
Cells(6, k + 1).Resize(last_ro - 4).Interior.ColorIndex = 24

Next
i = 7
Do Until Sheets("data2").Range("c" & i) = vbNullString
Set start_rg = Sheets("data2").Range("H" & i)
Set Find_Rg = serch_range.Find(Sheets("data2").Range("c" & i))
If Not Find_Rg Is Nothing Then
r = Find_Rg.Row - 2
Else: GoTo Next_i
End If
start_rg.Offset(, r).Interior.ColorIndex = 6
Next_i:
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub


 


 

07-04-2019 06:33 صباحا
icon هل يمكن كود يقوم بالترتيب التلقائي بشرطين  | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 
المشاركة الأصلية كتبت بواسطة:khaled alborene
اين يوضع هذا الماكرو 

See This video
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
07-04-2019 06:24 صباحا
icon هل يمكن كود يقوم بالترتيب التلقائي بشرطين  | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
07-04-2019 05:17 صباحا
icon هل يمكن كود يقوم بالترتيب التلقائي بشرطين  | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 جرب هذا الماكرو

Option Explicit

Sub Sort_Please()
Sheets("الاسماء").Range("A2:C" & Rows.Count).Sort , _
Key1:=Range("A3"), Key2:=Range("c3"), Header:=1
End Sub
05-04-2019 06:54 مساء
icon ترحيل الفواتير حسب اسم الشهر | الكاتب :salim |المنتدى: اكسيل شروحات ودروس
 
يارك الله بك استاذ علي 
لكن اسمح لي بهذا التعليق
 كما نعرف ان عمليات Select   ,Activate, Cpoy Pasts  بكشل متكرر   ترهق الاكسل 
عدا ان الكود سيذهب الى الشيت المعنية  ويسكب ذاكرته هناك ثم يعود الى الصفحة الاولى 
لذلك اقترح هذا التعديل على الكود ليصبح هكذا:
لا ننسى اضافة
Application.EnableEvents = False
Application.EnableEvents = true

 
حتى يتوقف الماكرو selection Change عن العمل مؤقتاً

Option Explicit
Sub Tarheel_New()
Dim x%, ir%, max_ro%
Dim My_Rg As Range
Application.EnableEvents = False
If ActiveSheet.Name <> "Main" Then Exit Sub
If Application.CountA(Range("b5:f5")) = 5 Then
 Set My_Rg = Range("a4").CurrentRegion
 max_ro = My_Rg.Rows.Count
x = Month([D2].Value)
ir = Sheets(x + 1).Range("a" & Rows.Count).End(xlUp).Row

Sheets(x + 1).Cells(ir + 1, 1).Resize(max_ro - 1, 6).Value = _
ActiveSheet.Cells(5, 1).Resize(max_ro - 1, 6).Value
Range("b5:f500").ClearContents
Range("d2").Select
Else
MsgBox ("يرجى التحقق من البيانات الصحيحة")
End If
Application.EnableEvents = True
End Sub
03-04-2019 02:20 مساء
icon مساعدة في كود طباعة | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 هذا الماكرو يفي بالغرض

Option Explicit
Sub set_print_area()
 Dim max_row%, max_col%
 With ActiveSheet
  max_row = .Range("a1").CurrentRegion.Rows.Count
  max_col = .Range("a1").CurrentRegion.Columns.Count
  .PageSetup.PrintArea = _
     Range(Cells(1, 1), Cells(max_row, max_col)).Address
 End With
End Sub


 
29-03-2019 07:41 صباحا
icon Dynamic Range With &amp;amp;quot;For - Next &amp;amp;quot; | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 
ممكن هذا الكود

Sub select_data()
Dim i%
i = 2
Do Until i = Range("a2", Range("a1").End(4)).Rows.Count + 2
    'your code Here
    'Exemple Range("a" & i).Select
 i = i + 1
 Loop
End Sub

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





الساعة الآن 05:59 صباحا

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