سليم حاصبيا

تم معالجة الامر و عسى ان يكون المطلوب الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim arr() Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") arr = Array("الصرف", "الوارد", "الرصيد") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop R.Cells(8, "K").Resize(, 3).Value = arr: Erase arr i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsNumeric(K.Cells(Actrow, "F")), K.Cells(Actrow, "F"), 0) R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), 0) R.Cells(m, "M") = _ R.Cells(m, "L") - R.Cells(m, "k") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "k").Resize(, 3).Formula = _ "=SUM(K9:K" & ALLROW - 1 & ")" R.Cells(ALLROW, "k").Resize(, 3).Value = _ R.Cells(ALLROW, "k").Resize(, 3).Value '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق للمرة الثانية SAL_My_data_2.xlsm

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

الكود المطلوب Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub Sub Tranfer_data() Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim arr() Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") arr = Array("التاريخ", "العميل", "البيان", _ "الوارد", "الصرف", "الرصيد") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("a8").CurrentRegion.Rows.Count - 1).ClearContents i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop R.Cells(start_Ro, 1).Resize(, 6).Value = arr i = 5 start_Ro = start_Ro + 1 '++++++++++++++++++++++++++++++++++++++ Do Until K.Range("C" & i) = vbNullString x = K.Range("D" & i) = mot: y = K.Range("C" & i) >= Start_date z = K.Range("C" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 6).Value = _ K.Cells(i, 3).Resize(, 6).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop '+++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data.xlsm

بعض الأخطاء التي اكتشفتها (على السريع)

شاهذد هذا الفيدو https://www.youtube.com/watch?v=6chyTSbIo6k

من العمود a الى العمود m هناك 13 عامود اي أعمده تريد منها

عندك هذه المعادلة فيالخلية C2 ولا أفهم ما هي =TickerChart|Live!'QO.1111.TAD$lasttradeprice' الرجاء كتابة التنائج يدوياً لمعرفة المطلوب

السؤال غير مفهوم على اي اساس تختار قيمة التغذية مثلا (الصف الاول او الثاني)

لك ما تريد الكود Option Explicit Sub get_data() Dim w As Worksheet, K As Worksheet Dim mot Dim RwB As Range, RwG As Range Dim F_rgB As Range, F_rgG As Range Dim first_ro%, act_row%, m% Set w = Sheets("Wakil"): Set K = Sheets("Khoulasa") mot = K.Range("G2") Set RwB = w.Range("A8").CurrentRegion.Columns(2) Set RwG = w.Range("G8").CurrentRegion.Columns(1) Union(K.Range("C6:E100"), K.Range("I6:K100")).ClearContents m = 6 Set F_rgB = RwB.Find(mot, lookat:=1) If Not F_rgB Is Nothing Then first_ro = F_rgB.Row: act_row = first_ro Do K.Cells(m, 3) = w.Cells(act_row, 4) K.Cells(m, 4) = w.Cells(act_row, 3) K.Cells(m, 5) = w.Cells(act_row, 5) Set F_rgB = RwB.FindNext(F_rgB) act_row = F_rgB.Row m = m + 1 Loop Until act_row = first_ro End If m = 6 '======================================== Set F_rgG = RwG.Find(mot, lookat:=1) If Not F_rgG Is Nothing Then first_ro = F_rgG.Row: act_row = first_ro Do K.Cells(m, 9) = w.Cells(act_row, "I") K.Cells(m, 10) = w.Cells(act_row, "H") K.Cells(m, 11) = w.Cells(act_row, "J") Set F_rgG = RwG.FindNext(F_rgG) act_row = F_rgG.Row m = m + 1 Loop Until act_row = first_ro End If '======================================== End Sub الملف مرفق (مجرد ما تغير شيئاً ما في الخلية G2 الماكرو يقوم بعمله) Khoulassa_by_Code.xlsm

زيادة في اثراء الموضوع و بعد اذن الاخ علي هذا الكود Option Explicit Sub get_value() Dim D As Worksheet, R As Worksheet Dim RgD As Range, RgR As Range Dim Dic As Object, x%, y%, m%, ky Set D = Sheets("Data"): Set R = Sheets("Repport") Set RgD = D.Range("A2", D.Range("A1").End(4)) Set RgR = R.Range("A2", R.Range("A1").End(4)) Set Dic = CreateObject("Scripting.Dictionary") If R.Range("E1").CurrentRegion.Rows.Count > 1 Then _ R.Range("E1").CurrentRegion.Offset(1).ClearContents m = 2 For x = 2 To RgR.Rows.Count + 1 For y = 2 To RgD.Rows.Count + 1 If D.Cells(y, 1) = R.Cells(x, 1) Then Dic(D.Cells(y, 1) & "*" & D.Cells(y, 3)) = _ Dic(D.Cells(y, 1) & "*" & D.Cells(y, 3)) + D.Cells(y, 2) End If Next For Each ky In Dic.keys R.Cells(m, "E") = Format(CDate(Split(ky, "*")(0)), "yyyy/mm/dd") R.Cells(m, "F") = Dic(ky) R.Cells(m, "G") = Split(ky, "*")(1) m = m + 1 Next ky Dic.RemoveAll Next End Sub الملف مرفق Mouwaredine.xlsm

ربما كا المطلوب Khoulassa.xlsx

بعد اذن اخي الرائد لا ضرورة لكل هذه الحلفات التكرارية (بدل التنقل داخل النطاق المطلوب نقله خلية خلية ) انسخ النطاق كاملاُ الى الخلية الهدف لاحظ هذا الكود Option Explicit Sub My_code_1() Dim CRow%, jRow%, HowMany% Dim rng As Range Dim I As Worksheet, S As Worksheet Set I = Sheets("INV"): Set S = Sheets("SLS") Set rng = Sheets("INV").Range("c14:c23") HowMany = Application.CountA(I.Range("c14").Resize(10)) CRow = S.Range("C1048576").End(xlUp).Row + 1 jRow = S.Range("J1048576").End(xlUp).Row + 1 CRow = Application.Max(jRow, CRow) I.Cells(14, "C").Resize(HowMany, 5).Copy S.Cells(CRow, "c").PasteSpecial (12) I.Range("G24:G27").Copy With S.Cells(CRow + HowMany, "J") .PasteSpecial (12), Transpose:=True .Resize(, 4).Interior.ColorIndex = 6 End With S.Cells(CRow, "H") = I.Cells(8, "D") S.Cells(CRow, "I") = I.Cells(7, "D") I.Range("C14:C23").ClearContents I.Range("D8").ClearContents Application.CutCopyMode = False End Sub الملف مرفق Salim_Book.xlsm

اضغط على السهم الاسود الصغير بجانب A to z (تصاعدي ) Z to A (تنازلي )

اتبع هذه الصورة

السلام عليكم و رمضان كريم 1- ليس للمرة الأولى اكرر انه لا لزوم ادراح بيانات من ألوف الصفوف (6000 صف) اذ يكفي ادراج نموذج صغير فقط لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الألوف منها ( فقط من ـأجل معاينه عمل الماكرو وتخفيف حجم الملف) 2-تم اخفاء بعض الاعمدة (وليس حذفها ) لمراقبة سير الكود والتمكن من رؤية الييانات/ يمكن اعادة اظهارها بسهولة 3- تم ارفاق نموذج عما تريد مع بضعة صفوف 4-الكود Option Explicit Sub copy_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S As Worksheet, T As Worksheet Dim Ros#, Rot#, x%, Num%, m% Set T = Sheets("Target_sh") Set S = Sheets("Source_sh") Ros = S.Cells(Rows.Count, 1).End(3).Row If Ros < 3 Then GoTo Leave_me_alone_Please Rot = T.Cells(Rows.Count, 1).End(3).Row If Rot < 2 Then GoTo Leave_me_alone_Please T.Range("A3:N" & Rot + 1).Clear m = 3 For x = 3 To Ros Num = S.Cells(x, "L") S.Cells(x, 1).Resize(, 13).Copy With T.Cells(m, 1).Resize(Num, 13) .PasteSpecial 12 .PasteSpecial 8 End With m = T.Cells(Rows.Count, 1).End(3).Row + 2 Next T.UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = 1 Leave_me_alone_Please: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Date_distribution.xlsm

Try this Formula =C3*(1+B3)

لا أعلم حقيقة ما المشكلة لان عندي Windows7 و Office2016 تأكد من هذا الشيء

تم التعديل بالنسبة للحطأ بمكن ان يكون اصدار الاوفيس قديم عندك Sortig_Data_with list.xlsm

بارك الله بك اخي رائد اليك كود اخر بنفس الموضوع لكنه يفوم بترتيب النتيجة ابجدياً (مع حق اختيار القيم الفريدة) Option Explicit Sub My_code() Dim list As Object Dim Rng As Range, rcell As Range Dim D As Worksheet, Lr_A% Dim Answer As Byte Set D = Sheets("Duplicates") Lr_A = D.Cells(Rows.Count, 1).End(3).Row Set list = CreateObject("System.Collections.ArrayList") Set Rng = D.Range("A2:A" & Lr_A) D.Range("D1").CurrentRegion.Clear Answer = MsgBox("Do you want all data Or Only the Unique values", 4) For Each rcell In Rng.Cells '++++++++++++++++++++++++++++++++++++++++++++++++++ If Answer <> 6 Then list.Add (rcell.Text) '* Else If Not list.Contains(rcell.Text) Then list.Add (rcell.Text) '** End If '+++++++++++++++++++++++++++++++++++++++ Next rcell list.Sort MsgBox Join(list.ToArray, vbCrLf) D.Range("D1").Resize(list.Count) = _ Application.Transpose(list.ToArray()) Set list = Nothing End Sub الملف مرفق Sortig_Data.xlsm

رمضان كريم الاستاذان عبدالفتاح في بي اكسيل و الرائد 77 الف مبروك الترقية التي تستحقانها عن جدارة

يا اخي لست بحاجة الى اكثر من 6000 صف لمعاينة عمل ماكرو الماكرو الذي ينفذ على صف واحد يمكن ان يعمل على الوف الصفوف تم ادراج ملف يحتوي على بضغة بيانات للتجربة واليك النتيجة الكود Option Explicit Sub SansDoublons_By_FirstAcurance() If ActiveSheet.Name <> "Sheet1" Then Exit Sub Dim d As Object Dim Lr_c#, i#, k#, a(), b() Dim x x = [G4].CurrentRegion.Rows.Count If x > 6 Then _ [G4].CurrentRegion.Offset(6).Resize(x - 6).Clear Lr_c = Cells(Rows.Count, "c").End(3).Row If Lr_c < 10 Then Exit Sub Set d = CreateObject("Scripting.Dictionary") a = Range("C10:D" & Lr_c) ReDim b(1 To UBound(a, 1)) For i = LBound(a) To UBound(a) If a(i, 1) <> vbNullString Then For k = 1 To UBound(a, 2): b(k) = a(i, k): Next d.Item(a(i, 1)) = b End If Next i With [G10].Resize(d.Count, UBound(a, 2)) .Value = Application.Transpose(Application.Transpose(d.items)) .Borders.LineStyle = 1 .InsertIndent 1 End With End Sub الملف مرفق Without_Duplicate.xlsm

السؤال غير واضح 1- لا اتعامل مع اي جدول يحتوي على خلايا مدمجة 2- تضع المدة بالشهر والنسبة بالسنوات كبف هذا 3- هل تريد النسبة ان تكون مركية او لا مثلاُ سنة وسبعة اشهر (19 شهر) كيف تحسبها (السنة الأولى ×4% و 7 اشهر× 5%) أو 19 شهر × 5% 4- اكمل الجدول ببضع بيانات ولو شكلية

قم بتعديل المعادلات كما تريد

تفضل الملف حاهز Salary program.xls

ربما كان المطلوب My_Merge.xlsm