حسونة حسين

اخى الكريم يمكنك الاستفادة من هذا الموضوع

وعليكم السلام ورحمة الله وبركاته الملف الخاص بك ليس به مشاكل

آمين يارب العالمين وإياكم الحمد لله الذي بنعمته تتم الصالحات

يمكنك الاستفادة من هذا الموضوع هنا فيه الموضوع الاصلي للبرنامج

اخى الكريم محمد عبدالصمد هل كتبت الارقام من ٥ الى نهايه ارقامك ال ٥٠٠٠ اسم كما طلب منك الاستاذ الكبير بن علية حاجى في المشاركه السابقه

اجعل تنسيق الخلايا general وستجد المعادله سليمه

الكود الخاص بك كان فيه حلقه تكراريه لطباعه جميع النطاق حتى لو كان لايوجد بيانات في النطاق فعدلت لك الكود بحيث ان لم يكن يوجد بيانات يتوقف الكود If Isnull([d12]) or [d12] = 0 then Exit

وعليكم السلام ورحمة الله وبركاته الحمد لله بنعمه تفضل جرب هذا التعديل لعله يفي بالمطلوب test.xlsm

تفضل اخى الكريم الملف بعد وضع الكود به كشوفات الطلبة للعام 2021-2022.xlsm

قبل كل كلمه اسمها Function ضع كلمه Ptrsafe لتصبح الكلمه PtrSafe Function

السلام عليكم ورحمة الله وبركاته وبها نبدأ تفضل جرب هذا التعديل Test.xlsx

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

وجزاكم مثله اخى الكريم آمين يارب العالمين وإياكم

وكود اخر اخى الكريم بدون مصفوفات Sub Total() Dim ws As Worksheet, SH As Worksheet Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False If Not Evaluate("isref('" & "Total" & "'!A1)") Then Sheets.Add.Name = "Total" Set SH = ThisWorkbook.Worksheets("Total") SH.Range("A1").Resize(1, 19).Value = Array("V", "HH", "J", "K", "L", "DD", "HH", "K", "L", "P", _ "GG", "S", "DF", "GH", "HJ", "KJ", "FGH", "G", "Remarks") For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Total" And ws.Name <> "SUMMARY" And ws.Name <> "TIME" And ws.Name <> "HOLD" Then 'كود للنسخ العادي بدون مصفوفات ويجلب لك نفس تنسيق البيانات الاصليه ws.Range("A6:S" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Copy _ SH.Range("A" & SH.Cells(Rows.Count, 2).End(xlUp).Row + 1) End If Next ws SH.Range("A1:S" & SH.Cells(Rows.Count, 2).End(xlUp).Row).EntireColumn.AutoFit Sheets("Total").Move ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Total.xlsb", FileFormat:=xlExcel12 Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False End Sub

اخى الكريم لجعل ملف التجميع منفصل كود بسيط قبل هذا السطر في الكود Application.ScreenUpdating = True ضع هذه الاسطر Sheets("Total").Move ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Total.xlsb", FileFormat:=xlExcel12

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

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

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

وجزاكم مثله اخى الكريم والحمد لله الذي بنعمته تتم الصالحات

الحمد لله الذي بنعمته تتم الصالحات آمين يارب العالمين وإياكم اخى

تم تعديل الكود في المشاركه السابقه

وعليكم السلام ورحمة الله وبركاته تفضل اخى الكريم Option Explicit Sub Test() Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sFile As String Application.ScreenUpdating = False Set WS = ThisWorkbook.Worksheets("ورقة1") sFile = ThisWorkbook.Path & "\" & "العملاء.xlsm" Set WB = Workbooks.Open(sFile, False) For Each SH In WB.Worksheets If SH.Name = WS.Cells(2, 3).Value Then WS.Cells(3, 3).Value = SH.Range("H2").Value Next SH WB.Close SaveChanges:=True Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته ضع هذا الكود في ملفك وشغله ستجد ملف باسم ملف REEL_DATA_OF_NOVEMBER_2021.Xlsb بجوار ملفك Sub Total() Dim ws As Worksheet, temp As Variant, arr As Variant, F As Boolean, lr As Long Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Total" And ws.Name <> "SUMMARY" And ws.Name <> "TIME" And ws.Name <> "HOLD" Then temp = ws.Range("A6:S" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value2 If F Then Dim I As Long, ii As Long, ub As Long ub = UBound(arr, 1) arr = Application.Transpose(arr) ReDim Preserve arr(1 To UBound(arr, 1), 1 To ub + UBound(temp, 1)) arr = Application.Transpose(arr) For I = LBound(temp, 1) To UBound(temp, 1) For ii = 1 To UBound(temp, 2) arr(ub + I, ii) = temp(I, ii) Next ii Next I Else arr = temp F = True End If End If Next ws If Not Evaluate("isref('" & "Total" & "'!A1)") Then Sheets.Add.Name = "Total" With Sheets("Total") .Range("A2:S65536").ClearContents .Range("A1").Resize(1, 19).Value = Array("V", "HH", "J", "K", "L", "DD", "HH", "K", "L", "P", _ "GG", "S", "DF", "GH", "HJ", "KJ", "FGH", "G", "Remarks") .Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr With .Range("A1:S" & .Cells(Rows.Count, 2).End(xlUp).Row) .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .RowHeight = 15 ActiveWindow.Zoom = 75 .EntireColumn.AutoFit .Borders.Value = 1 End With End With ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "REEL_DATA_OF_NOVEMBER_2021", FileFormat:=xlExcel12 Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True End Sub

وعليكم السلام ورحمة الله وبركاته جرب هذا التعديل اخى الكريم Private Sub CommandButton2_Click() 'Declare Variables Dim FSO Dim sFile As String Dim sSFolder As String Dim sDFolder As String 'This is Your File Name which you want to Copy sFile = TextBox1.Text 'اكتب الموقع المتواجد فيه الملفات التى تريد نسخها sSFolder = "D:\" 'Change to match the destination folder path sDFolder = ComboBox1.Value 'Create Object Set FSO = CreateObject("Scripting.FileSystemObject") 'Checking If File Is Located in the Source Folder If Not FSO.FileExists(SFolder & sFile) Then MsgBox "Specified File Not Found", vbInformation, "Not Found" 'Copying If the Same File is Not Located in the Destination Folder ElseIf Not FSO.FileExists(sDFolder & Dir(sFile)) Then FSO.CopyFile sFile, sDFolder, True MsgBox "Specified File Copied Successfully", vbInformation, "Done!" Else MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists" End If End Sub

وجزاكم مثله اخى الكريم آمين يارب العالمين وإياكم اخى والحمد لله الذي بنعمته تتم الصالحات