سليم حاصبيا

ممكن ان يكون المطلوب مجرد ما تكتب قي القائمة المنسدلة حرف او اكثر تندرج في الفائمة كل الاسماء التي تبدأ بهذا الحرف(الحروف) لتختار ما يناسبك Salim 2018.xlsm

تم معالجة الامر الكود Option Explicit Option Base 1 Sub copy_data_Salim() Dim My_Sheet As Worksheet Set My_Sheet = Sheets("SANADAT") Dim Target_Sh As Worksheet If ActiveSheet.Name <> My_Sheet.Name Then GoTo Exit_Me Dim laste_row% Dim Const_Srting$: Const_Srting = "OK" Dim k%, m%, i%, t% Dim Source_Array() ReDim Source_Array(1 To 11) Source_Array = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "N") Dim Target_Array() ReDim Target_Array(1 To 11) Target_Array = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M") k = My_Sheet.Cells(Rows.Count, 2).End(3).Row On Error Resume Next For i = 2 To k m = My_Sheet.Cells(i, Columns.Count).End(1).Column If My_Sheet.Cells(i, "q") = Const_Srting Then GoTo Next_I Set Target_Sh = Sheets(My_Sheet.Cells(i, "P") & "") laste_row = Target_Sh.Cells(Rows.Count, 3).End(3).Row + 1 For t = LBound(Source_Array) To UBound(Source_Array) Target_Sh.Cells(laste_row, Target_Array(t)) = _ My_Sheet.Cells(i, Source_Array(t)) Next My_Sheet.Cells(i, "Q") = Const_Srting Next_I: Next Exit_Me: Erase Source_Array: Erase Target_Array Application.ScreenUpdating = True End Sub الملف مرفق الايجار Salim With_Array.xlsm

استعمل هذا الكود لنقل البيانات الى الورقة(بدل الكود الطويل جداً عندك) Private Sub CommandButton1_Click() Dim iRow As Long, i% Dim ws As Worksheet Set ws = Worksheets("بيانات") iRow = ws.Cells(Rows.Count, 5) _ .End(3).Row + 1 For i = 5 To 15 ws.Cells(iRow, i) = Me.Controls("TextBox" & i) Me.Controls("TextBox" & i) = vbNullString Next Me.TextBox1.Value = iRow + 1 End Sub اما لتجعل الكومندبوتن يعمل على الانتر يمكن ذلك من خلال الدخول على properties لكومندبوتن و جعل Default تساوي true الملف مرفق check1salim.xlsm

هذا الكود لمثل هذه الحالة Option Explicit Sub give_data_salim() Dim m%, i%, x%, my_st$ Dim a As Boolean Dim match%, k%: k = 1 x = Range("Source_tabl").Rows.Count Dim find_range As Range Range("Source_tabl").Offset(1, 1).ClearContents For m = 2 To x my_st = Range("Source_tabl").Columns(1).Cells(m) If my_st = vbNullString Then k = k + 1: GoTo 2 For i = 1 To 4 a = IsError(Application.match(my_st, Range("tabl_" & i).Columns(1), 0)) If Not a Then match = Application.match(my_st, Range("tabl_" & i).Columns(1), 0) Set find_range = Range("tabl_" & i).Columns(1). _ Cells(match).Offset(-match + 1, -1) Range("Source_tabl").Columns(2).Cells(k + 1) = find_range.Value Range("Source_tabl").Columns(3).Cells(k + 1) = Range("tabl_" & i) _ .Columns(3).Cells(match) k = k + 1 GoTo 2 End If Next 2: Next End Sub

انظر الى المرفق salim Book.xlsx

الملف مضروب بفيروس و قد رفض الجهاز فتحه

جرب هذا الكود Option Explicit Sub copy_range() Dim lr2%, lrFeuil_2% lr2 = Sheets("2").Cells(Rows.Count, 1).End(3).Row If lr2 < 15 Then lr2 = 15 lrFeuil_2 = Sheets("Feuil2").Cells(Rows.Count, 1).End(3).Row + 1 With Sheets("2") Union(.Range("a16:i" & lr2), .Range("L16:V" & lr2)). _ Copy Sheets("Feuil2").Range("a" & lrFeuil_2) End With End Sub

تم معالجة الامر بواسطة كود جديد (تغيير اسم الصفحة الاولى الى SANADAT) لحسن عمل الماكرو الكود Option Explicit Sub copy_data() Dim My_Sheet As Worksheet Set My_Sheet = Sheets("SANADAT") Dim Target_Sh As Worksheet If ActiveSheet.Name <> My_Sheet.Name Then GoTo Exit_Me Dim laste_row% Dim Const_Srting$: Const_Srting = "OK" Dim k%, m%, i% k = My_Sheet.Cells(Rows.Count, 2).End(3).Row On Error Resume Next For i = 2 To k m = My_Sheet.Cells(i, Columns.Count).End(1).Column If My_Sheet.Cells(i, "q") = Const_Srting Then GoTo Next_I Set Target_Sh = Sheets(My_Sheet.Cells(i, "P") & "") laste_row = Target_Sh.Cells(Rows.Count, 2).End(3).Row + 1 My_Sheet.Cells(i, 2).Resize(1, m - 2).Copy _ Target_Sh.Range("b" & laste_row).Resize(1, m) My_Sheet.Cells(i, "Q") = Const_Srting Next_I: Next Exit_Me: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub الملف الايجار Salim.xlsm

جرب هذا الملف (يمكن تعديل نطاق البحث الى اي صف تريد)انا اخذت فقط أول 100 Book1 salim.xlsx

الكود الجديد لعمل هذا Sub Distribute_col() Application.EnableEvents = False Dim MY_Rg As Range Dim x%, n%, i% Dim k%: k = 1 Dim s%: s = 1 Dim my_arr(), my_arr_Item() Set MY_Rg = Range("i5").CurrentRegion Dim N_row As Double: N_row = MY_Rg.Rows.Count Set MY_Rg = MY_Rg.Resize(N_row - 1) N_row = MY_Rg.Rows.Count Dim st_to_del$ Range("LM6:LM" & N_row + 6).ClearContents x = Int(N_row / [LM1]) For n = 1 To N_row ReDim Preserve my_arr_Item(1 To s) my_arr_Item(s) = MY_Rg.Cells(n) ReDim Preserve my_arr(1 To s) my_arr(s) = "Section :" & k s = s + 1 If (n Mod x) = 0 Then k = k + 1 Next For i = LBound(my_arr) To UBound(my_arr) Cells(i + 5, "LM") = Application.Index(my_arr, _ Application.Match(my_arr_Item(i), my_arr_Item, 0)) Next st_to_del = [LN1] If st_to_del = "ALL" Then GoTo exit_Me For i = 6 To UBound(my_arr) + 5 If Range("e" & i) <> st_to_del Then Range("LM" & i) = vbNullString End If Next GoTo 2 exit_Me: '================================ For i = 6 To UBound(my_arr) + 5 If Range("e" & i) = "مستبعد" Then Range("LM" & i) = vbNullString End If Next 2: '============================= Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$LM$1" _ Or Target.Address = "$LN$1" Then _ Distribute_col End Sub

تم معالجة الامر(اختر المطلوب مستبعد وارد الخ....من القائمة المنسدلة) الكود Sub Distribute_col() Application.EnableEvents = False Dim MY_Rg As Range Dim x%, n%, i% Dim k%: k = 1 Dim s%: s = 1 Dim my_arr(), my_arr_Item() Set MY_Rg = Range("i5").CurrentRegion Dim N_row As Double: N_row = MY_Rg.Rows.Count Set MY_Rg = MY_Rg.Resize(N_row - 1) N_row = MY_Rg.Rows.Count Dim st_to_del$ Range("LM6:LM" & N_row + 6).ClearContents x = Int(N_row / [LM1]) For n = 1 To N_row ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Cells(n) ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k s = s + 1 If (n Mod x) = 0 Then k = k + 1 Next For i = LBound(my_arr) To UBound(my_arr) Cells(i + 5, "LM") = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0)) Next st_to_del = [LN1] If st_to_del = "ALL" Then GoTo exit_Me For i = 6 To UBound(my_arr) + 5 If Range("e" & i) <> st_to_del Then Range("LM" & i) = vbNullString End If Next exit_Me: Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$LM$1" Then Exit Sub Distribute_col End Sub الملف RTR1salim.rar

يجب تحميل الملف(أو قسم منه اذا كان كبيراً) للعمل عليه

الكود Sub Distribute_col() Application.EnableEvents = False Dim MY_Rg As Range Dim x%, n%, i% Dim k%: k = 1 Dim s%: s = 1 Dim my_arr(), my_arr_Item() Set MY_Rg = Range("i5").CurrentRegion Dim N_row As Double: N_row = MY_Rg.Rows.Count Set MY_Rg = MY_Rg.Resize(N_row - 1) N_row = MY_Rg.Rows.Count Range("LM6:LM" & N_row + 6).ClearContents x = Int(N_row / [LM1]) For n = 1 To N_row ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Cells(n) ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k s = s + 1 If (n Mod x) = 0 Then k = k + 1 Next For i = LBound(my_arr) To UBound(my_arr) Cells(i + 5, "LM") = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0)) Next Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$LM$1" Then Exit Sub Distribute_col End Sub

الكود Sub REPORT_salim() Application.ScreenUpdating = False Dim My_name$ Dim SpecLr% Dim sh As Worksheet: Set sh = Sheets("سندات القبض") Dim k%, i%: k = Sheets.Count Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row If LrP = 1 Then LrP = 2 For i = 2 To k My_name = sh.Cells(i, "P") If sh.Cells(i, "q") = "تم الترحيل" Then GoTo NEXT_I SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1 With Sheets(My_name) .Cells(SpecLr, 3) = sh.Cells(i, "B") .Cells(SpecLr, 4) = sh.Cells(i, "D") .Cells(SpecLr, 5) = sh.Cells(i, "e") .Cells(SpecLr, 6) = sh.Cells(i, "f") .Cells(SpecLr, 7) = sh.Cells(i, "h") .Cells(SpecLr, 8) = sh.Cells(i, "i") .Cells(SpecLr, 9) = sh.Cells(i, "j") .Cells(SpecLr, 10) = sh.Cells(i, "k") .Cells(SpecLr, 11) = sh.Cells(i, "n") sh.Cells(i, "q") = "تم الترحيل" End With NEXT_I: Next Application.ScreenUpdating = True End Sub

الكود يعمل عندي بشكل ممتاز RTR1.xlsm

جرب هذا الماكرو Option Explicit Sub Distribute_col() Dim MY_Rg As Range Dim x%, t%, n% Dim k%: k = 1 Set MY_Rg = Range("a5").CurrentRegion.Columns(2) Dim N_row As Double: N_row = MY_Rg.Rows.Count Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1) N_row = MY_Rg.Rows.Count x = Int(N_row / [f1]) t = x * [f1] For n = 1 To N_row MY_Rg.Cells(n).Offset(0, 2) = "sec" & k If (n Mod x) = 0 Then k = k + 1 Next End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$1" Then Exit Sub Distribute_col End Sub ربما ينفع هذا الكود Sub Distribute_col() Application.EnableEvents = False Dim MY_Rg As Range Dim x%, t%, n% Dim k%: k = 1 Dim s%: s = 1 Dim my_arr(), my_arr_Item() Set MY_Rg = Range("a5").CurrentRegion.Columns(2) Dim N_row As Double: N_row = MY_Rg.Rows.Count Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1) N_row = MY_Rg.Rows.Count Range("D5:D" & N_row + 4).ClearContents x = Int(N_row / [f1]) t = x * [f1] For n = 1 To N_row ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Rows.Cells(n) ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k s = s + 1 If (n Mod x) = 0 Then k = k + 1 Next For i = LBound(my_arr) To UBound(my_arr) Cells(i + 4, 4) = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0)) Next Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$1" Then Exit Sub Distribute_col1 End Sub

جرب هذا الماكرو Option Explicit Sub Distribute_col() Dim MY_Rg As Range Dim x%, t%, n% Dim k%: k = 1 Set MY_Rg = Range("a5").CurrentRegion.Columns(2) Dim N_row As Double: N_row = MY_Rg.Rows.Count Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1) N_row = MY_Rg.Rows.Count x = Int(N_row / [f1]) t = x * [f1] For n = 1 To N_row MY_Rg.Cells(n).Offset(0, 2) = "sec" & k If (n Mod x) = 0 Then k = k + 1 Next End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$1" Then Exit Sub Distribute_col End Sub

ريما كان المطلوب الكود Option Explicit Sub give_data() Dim m%, i%, x%, my_st$ Dim a As Boolean Dim match% x = Range("Source_tabl").Rows.Count Dim find_range As Range Range("Source_tabl").Offset(1, 1).ClearContents For m = 2 To x my_st = Range("Source_tabl").Columns(1).Cells(m) If my_st = vbNullString Then Exit For For i = 1 To 3 a = IsError(Application.match(my_st, Range("tabl_" & i).Columns(1), 0)) If Not a Then match = Application.match(my_st, Range("tabl_" & i).Columns(1), 0) Set find_range = Range("tabl_" & i).Columns(1). _ Cells(match).Offset(-match + 1, -1) Range("Source_tabl").Columns(2).Cells(m) = find_range.Value Range("Source_tabl").Columns(3).Cells(m) = Range("tabl_" & i) _ .Columns(3).Cells(match) GoTo 1 End If Next 1: Next End Sub الملف البحث_بشروط Salim.xlsm

لمنع تكرار الترحيل البيانات التي تم نقلها استبدل الكود الى هذا Sub REPORT_salim() Application.ScreenUpdating = False Dim My_name$ Dim SpecLr% Dim sh As Worksheet: Set sh = Sheets("سندات القبض") Dim k%, j%, i%: k = Sheets.Count Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row If LrP = 1 Then LrP = 2 Dim New_lr% For i = 2 To k On Error Resume Next My_name = sh.Cells(i, "P") SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1 With Sheets(My_name) For j = 3 To 17 .Cells(SpecLr, j) = sh.Cells(i, j - 1) Next '========================== New_lr = .Cells(Rows.Count, "c").End(3).Row .Range("C9:Q" & New_lr).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7 _ , 8, 9, 10, 11, 12, 13, 14, 15), Header:=xlYes '============================== End With Next Application.ScreenUpdating = True End Sub

تحميل الملف ضروري لمعرفة الخطأ

تعديل على الملف والكود Sub REPORT_salim() Application.ScreenUpdating = False Dim My_name$ Dim SpecLr% Dim sh As Worksheet: Set sh = Sheets("سندات القبض") Dim k%, j%, i%: k = Sheets.Count Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row If LrP = 1 Then LrP = 2 For i = 2 To k My_name = sh.Cells(i, "P") SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1 With Sheets(My_name) For j = 3 To 17 .Cells(SpecLr, j) = sh.Cells(i, j - 1) Next End With Next Application.ScreenUpdating = True End Sub Ijarat_salim.xlsm

هذا الكود Sub REPORT_salim() Application.ScreenUpdating = False Dim My_name$ Dim SpecLr% Dim sh As Worksheet: Set sh = Sheets("سندات القبض") Dim k%, i%: k = Sheets.Count Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row If LrP = 1 Then LrP = 2 For i = 2 To k My_name = sh.Cells(i, "P") SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1 With Sheets(My_name) .Cells(SpecLr, 3) = sh.Cells(i, "B") .Cells(SpecLr, 4) = sh.Cells(i, "D") .Cells(SpecLr, 5) = sh.Cells(i, "e") .Cells(SpecLr, 6) = sh.Cells(i, "f") .Cells(SpecLr, 7) = sh.Cells(i, "h") .Cells(SpecLr, 8) = sh.Cells(i, "i") .Cells(SpecLr, 9) = sh.Cells(i, "g") .Cells(SpecLr, 10) = sh.Cells(i, "k") .Cells(SpecLr, 11) = sh.Cells(i, "n") .Cells(SpecLr, 12) = sh.Cells(i, "l") End With Next Application.ScreenUpdating = True End Sub

بعد اذن اخي زيزو (مع او بدون ترقيم حسب الاختيار) الكود Option Explicit Sub extract_data() Dim My_Sh As Worksheet: Set My_Sh = Sheets("ورقة1") Dim s%, Initial_string$, i%: i = 4: s = 1 Dim LrF As Long Dim x As Boolean x = My_Sh.Range("j2") = "Yes" Application.ScreenUpdating = False With My_Sh LrF = .Cells(Rows.Count, "F").End(3).Row If LrF < 4 Then LrF = 4 .Range("f4:F" & LrF).Clear Initial_string = .Cells(2, "G") & .Cells(2, "F") & .Cells(2, "H") Do Until .Cells(i, 2) = vbNullString If .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) = Initial_string Then With .Cells(i, "F") .Value = IIf(x, "M" & s, "M") With .Font .ColorIndex = 3 .Bold = True End With End With s = s + 1 End If i = i + 1 Loop End With Application.ScreenUpdating = True End Sub الملف TEXT Salim1.xls

حل اخر مع قليل من التفاصيل TEXT Salim.xlsx

استبدل الكود بهذا مع مراعاة وضع الخلايا من الصفحة(سند قبض) في اماكنها الصحيحة في المرة المقبلة ابتعد قدر الامكان عن عدو الاكواد الأول (أقصد الخلايا المدمجة) تم بالخطأ مسح اسماء البنايات (يمكن اعادة ادراجها بالقائمة المتسدلة) Option Explicit Sub Salim() Dim my_sh As Worksheet: Set my_sh = Sheets("سندات القبض") Dim Sanad As Worksheet: Set Sanad = Sheets("سند قبض") Dim x% x = my_sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 Dim i%, s With my_sh.Range("b" & x) For i = 0 To 14 Select Case i Case Is = 0: s = Sanad.[h3].Value: Sanad.[h3].Value = vbNullString Case Is = 1: s = Sanad.[d5].Value: Sanad.[d5].Value = vbNullString Case Is = 2: s = Sanad.[f7].Value: Sanad.[f7].Value = vbNullString Case Is = 3: s = Sanad.[c7].Value: Sanad.[c7].Value = vbNullString Case Is = 4: s = Sanad.[a7].Value: Sanad.[a7].Value = vbNullString Case Is = 5: s = Sanad.[i9].Value Case Is = 6: s = Sanad.[d10].Value: Sanad.[d10].Value = vbNullString Case Is = 7: s = Sanad.[a10].Value: Sanad.[a10].Value = vbNullString Case Is = 8: s = Sanad.[i9].Value: Sanad.[i9].Value = vbNullString Case Is = 9: s = Sanad.[i12].Value: Sanad.[i12].Value = vbNullString Case Is = 10: s = Sanad.[i13].Value: Sanad.[i13].Value = vbNullString Case Is = 11: s = Sanad.[i14].Value: Sanad.[i14].Value = vbNullString Case Is = 12: s = Sanad.[i15].Value: Sanad.[i15].Value = vbNullString Case Is = 13: s = Sanad.[i16].Value: Sanad.[i16].Value = vbNullString Case Is = 14: s = Sanad.[i17].Value: Sanad.[i17].Value = vbNullString End Select .Offset(0, i) = s Next End With End Sub الايجارات.xlsm