محمد هشام.

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

آسف أخي @saad1391 فعلا لم انتبه لردك إلا بالصدفة كان الفكرة الموضحة في الصور قد تم تنفيذها يدويا لاكن بعد محاولة تنفيذها بواسطة الأكواد إكتشفت ان طريقة تصميمك للملف وكثرة الخلايا المدمجة يصعب التعامل معها حاول إلغاء دمجها قدر الإمكان للتخلص من الأعمدة الفارغة التي تعيق استخراج النتائج بشكل صحيح

جرب هدا Dim OnRng(), tbl, Irow, ColVisu(), Dates(), Choix() Private Sub UserForm_Initialize() tbl = "Table2" OnRng = Range(tbl).value For i = 1 To UBound(OnRng): OnRng(i, 2) = CDate(OnRng(i, 2)): Next i Irow = Range(tbl).Columns.Count ColVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) ListBox1.ColumnCount = 12 Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 3)) = "" Next i Choix = d.keys '================' رقم السيارة ============== Tri Choix, LBound(Choix), UBound(Choix) Dim iTemp As Variant For i = LBound(Choix) To (UBound(Choix) - LBound(Choix)) \ 2 iTemp = Choix(i) Choix(i) = Choix(UBound(Choix) - i) Choix(UBound(Choix) - i) = iTemp Next i Me.ComboBox1.List = Choix '================' اسم السائق ======================== Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 4)) = "" Next i Choix = d.keys Tri Choix, LBound(Choix), UBound(Choix) Me.ComboBox4.List = Choix Set d = CreateObject("scripting.dictionary") colDate = 2 For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, colDate)) = "" Next i Dates = d.keys Tri Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) Filtre End Sub Sub Filtre() Dim tbl() clé = Me.ComboBox1: If clé = "" Then clé = "*" cléLieu = Me.ComboBox4: If cléLieu = "" Then cléLieu = "*" début = CDate(Me.ComboBox2) fin = CDate(Me.ComboBox3) colDate = 2 n = 0 For i = LBound(OnRng) To UBound(OnRng) If OnRng(i, colDate) >= début And OnRng(i, colDate) <= fin And OnRng(i, 3) Like clé And OnRng(i, 4) Like cléLieu Then n = n + 1: ReDim Preserve tbl(1 To Irow, 1 To n) c = 0 For Each K In ColVisu c = c + 1: tbl(c, n) = OnRng(i, K) Next K End If Next i If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear MsgBox "لم يتم العثور على بيانات مطابقة", vbInformation, "نتائج التصفية" End If End Sub ListBox1.ColumnCount = 12-V2.xlsm

نعم مثلا كومبوبوكس 4 ,و5 يتم تعبئتها من الأعمدة 1,و2 وانت واضع شرط التحقق من قيم العمود D هل هو خطأ ؟ اظافة ان الطريقة المستخدمة في الملف لن تمكنك من عرض أكثر من 10 أعمدة لو وضحت ما تحاول فعله ممكن نعرض البيانات عادي على الليست بوكس وفلترتها بين تاريخين والشروط المطلوبة اذا حددت أعمدتها

وعليكم السلام ورحمة الله تعالى وبركاته قبل الخوض في مسألة عرض الأعمدة أظن أنك بحاجة لمراجعة الشروط على الأكواد التالية For i = 2 To lastRow If (LCase(ws.Cells(i, 3).value) = LCase(searchValue1) Or searchValue1 = "ALL") And _ (LCase(ws.Cells(i, 4).value) = LCase(searchValue2) Or searchValue2 = "ALL") And _ ws.Cells(i, 3).value Like "*" & searchValue1 & "*" And _ (Not includeDates Or (ws.Cells(i, 2) >= DateMin And ws.Cells(i, 2) <= DateMax)) Then '================================================= ' For i = 2 To lastRow If Trim(ws.Cells(i, "b").value) = ComboBox5.value Then ComboBox4.value = ws.Cells(i, "a").value Exit For End If Next i أعتقد ان عناصر combobo4 و combobox 5 يتم تعبئتها بشكل خاطئ يرجى التأكد منها أولا أو تحديد الأعمدة المطلوبة دون الحاجة لإرفاق اي أكواد

وعليكم السلام ورحمة الله تعالى وبركاته عبارة تعديل على الكود تشمل عدة احتمالات المرجوا توضيح طلبك بدقة لنستطيع مساعدتك

العفو أخي @ahmed sewelam يسعدنا أننا إستطعنا مساعدتك ' تحويل القيمة المدخلة الى تاريخ MinDate و MaxDate MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) ' جلب البيانات من النطاق A3:I a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ' قواميس لتخزين البيانات المجمعة ' dc لتخزين صافي المبيعات، dnc لتخزين صافي المردودات، dnc1 لتخزين المندوب Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) 'MinDate و MaxDate إذا كان التاريخ ' (العمود B) a(i, 2)' 'يقع بين If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) ' العمود G: "المندوب" ' إذا لم يكن المندوب موجودا مسبقا في القاموس نقوم بإضافته وتخزين القيم المبدئية If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6) ' العمود F: "تخزين اسم المندوب" dc(tmp) = a(i, 8) ' العمود H: "تخزين صافي المبيعات" dnc(tmp) = a(i, 9) ' العمود I: "تخزين صافي المردودات" Else ' إذا كان المندوب موجودا إضافة القيم إلى القيم المخزنة dc(tmp) = dc(tmp) + a(i, 8) ' تجميع عدد المبيعات dnc(tmp) = dnc(tmp) + a(i, 9) ' تجميع المردودات End If End If Next i 'إذا كانت القواميس تحتوي على بيانات (dc.Count > 0) ' مطابقة للفترة الزمنية المحددة If dc.Count > 0 Then Application.ScreenUpdating = False 'مسح أي محتوى سابق من النطاق C12:F في ورقة "Report" With dest.Range("C12:F" & dest.Rows.Count) .ClearContents .ClearFormats End With ' تعيين حجم المصفوفة arr بناءا على عدد العناصر في القاموس dc n = 1 ReDim arr(1 To dc.Count, 1 To 4) ' تعبئة المصفوفة For Each key In dc.Keys arr(n, 1) = dnc1(key) ' العمود الأول في arr: "كود" arr(n, 2) = key ' العمود الثاني : "المندوب" arr(n, 3) = dc(key) ' العمود الثالث : "إجمالي المبيعات" arr(n, 4) = dnc(key) ' العمود الرابع : "إجمالي المردودات" n = n + 1 Next key ' نسخ محتويات المصفوفة "Report"(C12) بداية من الخلية dest.Range("C12").Resize(dc.Count, 4).Value = arr ' تحديد الصف الأخير المستخدم بعد إدراج البيانات lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row ' إضافة "الإجمالي" في العمود D أسفل البيانات dest.Cells(lastRow + 1, "D").Value = "الإجمالي" 'وضع الإجمالي أسفل التقرير ' للأعمدة E و F (صافي المبيعات وصافي المردودات)' For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col ' يتم وضع تاريخ البداية والنهاية في الخلايا E9 و F9 dest.Range("E9").Value = MinDate dest.Range("F9").Value = MaxDate ' نطاق البيانات في التقرير Set Rng = dest.Range("C12:F" & lastRow) ' إضافة حدود حول كل صف في التقرير يحتوي على بيانات For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub CommandButton1_Click() Dim MinDate As Date, MaxDate As Date Dim WS As Worksheet, dest As Worksheet Dim a As Variant, tmp As String Dim dc As Object, dnc As Object, dnc1 As Object Dim arr() As Variant, n As Long, lastRow As Long, i As Long Dim Rng As Range, C As Range, col As Variant, key As Variant Set WS = Sheets("DATA"): Set dest = Sheets("Report") If Not IsDate(TextBox1.Value) Or Not IsDate(TextBox2.Value) Then MsgBox "المرجوا التحقق من التواريخ", vbExclamation Exit Sub End If MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6): dc(tmp) = a(i, 8): dnc(tmp) = a(i, 9) Else dc(tmp) = dc(tmp) + a(i, 8): dnc(tmp) = dnc(tmp) + a(i, 9) End If End If Next i If dc.Count > 0 Then Application.ScreenUpdating = False With dest.Range("C12:F" & dest.Rows.Count) .ClearContents: .ClearFormats End With n = 1 ReDim arr(1 To dc.Count, 1 To 4) For Each key In dc.Keys arr(n, 1) = dnc1(key): arr(n, 2) = key: arr(n, 3) = dc(key): arr(n, 4) = dnc(key) n = n + 1 Next key dest.Range("C12").Resize(dc.Count, 4).Value = arr lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row dest.Cells(lastRow + 1, "D").Value = "الإجمالي" For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col dest.Range("E9").Value = MinDate: dest.Range("F9").Value = MaxDate Set Rng = dest.Range("C12:F" & lastRow) For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C Else MsgBox "لا توجد بيانات تطابق التواريخ المحددة" End If Application.ScreenUpdating = True End Sub TEST v1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim n As Object: Set n = CreateObject("Scripting.Dictionary") Dim i As Long, ling As Long, lastRow As Long, tmp As String, kay As String, j As Variant If Not Intersect(Target, WS.Range("A4:B" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False With WS ' مسح النتائج السابقة .Range("I3:J" & .Rows.Count).ClearContents lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ling = 3 ' تحديد صف وضع النتائج ' بداية من الصف 4 For i = 4 To lastRow tmp = .Cells(i, 1).value ' الحصول على القيمة من عمود A kay = .Cells(i, 2).value ' الحصول على القيمة من عمود B ' التأكد من أن القيم ليست فارغة If tmp <> "" And kay <> "" Then If n.Exists(tmp) Then n(tmp) = n(tmp) & ", " & kay Else n.Add tmp, kay End If End If Next i For Each j In n.Keys .Cells(ling, 9).value = j ' القيم الفريدة في عمود I .Cells(ling, 10).value = n(j) ' القيم المرتبطة في عمود J ling = ling + 1 Next j ' تعديل عرض العمود ليتناسب مع المحتوى .Columns("J").AutoFit End With Application.ScreenUpdating = True End If End Sub TEST CODE.xlsb

كما سبق الدكر من الأستاد @عبدالله بشير عبدالله يكفي تعديل هدا السطر للحصول على مجموع كل تاريخ OnRng(n, tmp + 1) = OnRng(n, tmp + 1) + g(i, 1) لاكن قبل الجمع وتفديا للأخطاء يجب أولا التحقق من البيانات على العمود (G) لان وجود بيانات غير رقمية من شأنه أن يسبب أخطاء Sub ItemsRollKgmsKnt() Dim d1 As Object, d2 As Object Dim OnRng() As Variant, a, g, d As Variant Dim tmp As Integer, n As Integer, mx As Integer Dim WS As Worksheet: Set WS = Sheets("KN") Dim f As Worksheet: Set f = Sheets("MM") Set d1 = CreateObject("Scripting.Dictionary") Set d2 = CreateObject("Scripting.Dictionary") a = WS.Range("A2:A" & WS.[A65000].End(xlUp).Row).Value g = WS.Range("G2:G" & WS.[A65000].End(xlUp).Row).Value d = WS.Range("D2:D" & WS.[A65000].End(xlUp).Row).Value Application.ScreenUpdating = False f.Range("A2:AF" & f.Rows.Count).ClearContents For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1 End If Next i mx = 31 ReDim OnRng(1 To d1.Count, 1 To mx + 1) For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then n = d1(a(i, 1)) tmp = Day(CDate(d(i, 1))) If tmp >= 1 And tmp <= 31 Then OnRng(n, 1) = a(i, 1) If IsNumeric(OnRng(n, tmp + 1)) And IsNumeric(g(i, 1)) Then OnRng(n, tmp + 1) = OnRng(n, tmp + 1) + Round(g(i, 1), 0) Else OnRng(n, tmp + 1) = Round(g(i, 1), 0) End If End If End If Next i With f .Range("A2").Resize(d1.Count, mx + 1).Value = OnRng .Columns.AutoFit End With Application.ScreenUpdating = True End Sub KNTPROD V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته المشكلة ليست في رؤوس الأعمدة المختلفة ولا في مكان وجودها ضمن كل ورقة المشكلة في أسمائها المكررة على نفس الملف أكثر من مرة أعتقد أنه يمكنك الاعتماد على الصف 19 كعناوين للمجموعات مثلا (المهارات الرقمية-اللغة الإنجليزية ) وعند وجودها يتم البحث عن تطابق الفرع الصف 20 (واجبات-مشاركة) وهكدا.... لكي تتمكن من التغلب على مسألة تكرار رؤوس الأعمدة وجلب بيانات كل عمود في مكانه المناسب لاحظ معي فرع الوجبات فقط لورقة واحدة في الصورة المرفقة بالنسبة للنتائج ستكون على الشكل التالي على حسب احتياجاتك إما نسخها كقيم أو مع التنسيقات ادا كان هدا ما تنوي فعله قم باختيار الطريقة المناسبة لك وسوف نكون سعداء بمساعدتك بالتوفيق .....

اخي الكود يشتغل معي بدون مشاكل كما في الصورة المرفقة على العموم تم تعديل الكود في المشاركة السابقة مع تعديل بسيط للكود الأول يمكنك تجربتهم وإختيار ما يناسبك Book2 v2.xlsm

Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "ÇáÃÓãÇÁ": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With Dim Hrd As String For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then Hrd = WS.Cells(3, cell.Column).Value kay = Hrd Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub New V2.xlsb

Sub CopyData() Dim ColArr(1 To 9) As Long Dim WS As Worksheet, dest As Worksheet Dim a As Range, n As Integer, lastRow As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set WS = Sheets("DATA") Set dest = Sheets("Summary") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 7 Then Exit Sub dest.Range("A1:I" & dest.Cells(dest.Rows.Count, 1).End(xlUp).Row).Clear dest.Range("A1").Resize(lastRow - 6, 9).Value = WS.Range("A7:I" & lastRow).Value ColArr(1) = 30 ColArr(2) = 23 ColArr(3) = 22 ColArr(4) = 13 ColArr(5) = 18 ColArr(6) = 16 ColArr(7) = 25 ColArr(8) = 30 ColArr(9) = 20 With dest .Columns.Font.Name = "Cambria" .Columns.Font.Size = 18 For n = 1 To 9 Set a = dest.Range(dest.Cells(2, n), dest.Cells(lastRow, n)) Select Case n Case 1: a.NumberFormat = "###0" Case 2: a.NumberFormat = "#,##0" Case 3: a.NumberFormat = "#,##0.00" Case 4: a.NumberFormat = "0.00%" Case 5: a.NumberFormat = "@" Case 6: a.NumberFormat = "dd/mm/yyyy" Case 7: a.NumberFormat = "$#,##0.00" Case 8: a.NumberFormat = "0.00%" Case 9: a.NumberFormat = "General" End Select Next n For n = 1 To 9 dest.Columns(n).ColumnWidth = ColArr(n) dest.Columns(n).HorizontalAlignment = xlCenter dest.Columns(n).VerticalAlignment = xlCenter Next n dest.Rows(1).RowHeight = WS.Rows(7).RowHeight End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub

نعم ليس هناك اي ترقيم هدا فقط نسخ للقيم الموجودة على الورقة DATA في الصف الأول أظن انك تقصد هدا

هل تقصد هدا

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub لقد لاحظت وجود أسماء رقمية في عمود المركز ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then ترحيل 1 الى شيتات منفصلة v1.xlsb

يمكنك فقط تعديل السطور التالية OnRng = WS.Range("A7:I" & lastRow).Value dest.Range("A2").Resize(lastRow - 6, 9).Value = OnRng اليك مثال لتنفيد طلبك Set WS = Sheets("DATA"): Set dest = Sheets("Summary") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 8 Then Exit Sub 'افراغ البيانات السابقة dest.Range("A2:I" & dest.Cells(dest.Rows.Count, 1).End(xlUp).Row).Clear ' نطاق البيانات المرغوب نسخها OnRng = WS.Range("A7:I" & lastRow).Value ' تحديد مكان اللصق dest.Range("A2").Resize(lastRow - 6, 9).Value = OnRng 'عرض الاعمدة ColArr = Array(30, 23, 22, 13, 18, 16, 25, 30, 20) ' حجم ونوع الخط With dest .Columns.Font.Name = "Cambria" .Columns.Font.Size = 18 'تنسيق مخصص لكل عمود For n = 1 To 9 Select Case n Case 1 .Columns(n).NumberFormat = "###0" Case 2 CODE.......... .......... End Select ' إظافة التنسيقات .Columns(n).ColumnWidth = ColArr(n - 1) .Columns(n).HorizontalAlignment = xlCenter .Columns(n).VerticalAlignment = xlCenter Next n 'تنسيق الصفوف For i = 2 To lastRow - 6 dest.Rows(i).RowHeight = WS.Rows(i + 5).RowHeight Next i End With Book2.xlsm

لا أعلم ما تحاول فعله لاكن جرب وضع الكود التالي في Module Public Sub RunCode() Dim WS As Worksheet, dest As Worksheet Dim tmp As Double, cell As Range Set WS = ThisWorkbook.Sheets("الادخال") Set dest = ThisWorkbook.Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then On Error Resume Next Set cell = dest.Range("A2:A" & _ dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole) On Error GoTo 0 If Not cell Is Nothing Then cell.Offset(0, 19).Value = Date End If End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Application.OnKey "{F10}", "RunCode" End Sub '==================== Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F10}" End Sub بهذه الطريقة بعد إظافة رقم الإدخال يمكنك تشغيل الكود باستخدام زر F10 فقط من لوحة المفاتيح (يمكنك تعيدله بما يناسبك ) ولا يستجيب أثناء التنقل أو تحديد خلايا أخرى 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي مع تعديل التنسيقات بما يناسبك Sub TransferDataAndFormat() Dim WS As Worksheet, dest As Worksheet, ColArr As Variant Dim OnRng As Variant, lastRow As Long, n As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set WS = Sheets("DATA") Set dest = Sheets("Summary") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 8 Then Exit Sub OnRng = WS.Range("A8:I" & lastRow).Value dest.Range("A8").Resize(lastRow - 7, 9).Value = OnRng ColArr = Array(25, 23, 22, 13, 18, 16, 25, 30, 20) With dest .Columns.Font.Name = "Arial" .Columns.Font.Size = 14 For n = 1 To 9 Select Case n Case 1 .Columns(n).NumberFormat = "###0" Case 2 .Columns(n).NumberFormat = "#,##0" Case 3 .Columns(n).NumberFormat = "#,##0.00" Case 4 .Columns(n).NumberFormat = "0.00%" Case 5 .Columns(n).NumberFormat = "@" Case 6 .Columns(n).NumberFormat = "dd/mm/yyyy" Case 7 .Columns(n).NumberFormat = "$#,##0.00" Case 8 .Columns(n).NumberFormat = "0.00%" Case 9 .Columns(n).NumberFormat = "General" End Select .Columns(n).ColumnWidth = ColArr(n - 1) Next n End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub Book1.xlsm

إذا تم إدخال قيمة رقمية في الخلية C5 يقوم الكود بالبحث عن نفس الرقم في العمود الأول (A) في ورقة البيانات و تحديث التاريخ في العمود (T) يمكنك تعديله بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet, dest As Worksheet Dim tmp As Double, n As Long,cell As Range Set WS = ThisWorkbook.Sheets("الادخال") Set dest = ThisWorkbook.Sheets("البيانات") If Not Intersect(Target, WS.Range("C5")) Is Nothing Then tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then On Error Resume Next Set cell = dest.Range("A2:A" & _ dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole) On Error GoTo 0 If Not cell Is Nothing Then cell.Offset(0, 19).Value = Date End If End If End If End Sub 1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub TransferDate() Dim tmp As Double, n As Long Dim WS As Worksheet, dest As Worksheet Set WS = Sheets("الادخال") Set dest = Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then n = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row + 1 dest.Cells(n, 1).Value = tmp dest.Cells(n, 20).Value = Date End If End Sub للترحيل الى نفس الخلايا بشكل دائم Sub TransferDateFix() Dim tmp As Double Dim WS As Worksheet, dest As Worksheet Set WS = Sheets("الادخال") Set dest = Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then dest.Range("A2").Value = tmp dest.Range("T2").Value = Date End If End Sub معادلة الرقم كتابة + ترحيل رقم الادخال الى شيت اخر استنادا لرقم الادخال.xlsb

نعم أظن أن نسخة 2013 تشتغل على Windows 7 Service Pack 1 وما فوق

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

جرب تحميل نسخة أحدث https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file