نجوم المشاركات

ولا يهمك ده مرفقك بعد التعديل تدلل بيانات المدرسين (1).zip

ضبط التلاعب بتاريخ الكمبيوتر الشرح بالفيديو التالي . Manipulating computer Date settings.rar

بعد تجربة الفكرة ، وبغض النظر عن أنها تحتاج فعلاً لإنترنت كي تتم المقارنة ، هذه تجربتي الفعلية موضحة في الصورة التالية .. هل من تفسير استاذنا الغالي ؟؟ 😊 ايضاً عند عدم الاتصال بالانترنت بقي التاريخ الدولي هو نفسه ، ولا اعلم مصدره ان لم يكن هناك انترنت في الكمبيوتر !!

وعليكم السلام ورحمة الله تعالى وبركاته للتنفيد على المصنف الخارجي معاهد ورقة معهد Public Property Get f() As Worksheet: Set f = ThisWorkbook.Sheets("test"): End Property Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "معاهد.xlsm" wsName = "معهد" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property Sub Split_Rows() Dim xColor As Long: xColor = RGB(204, 255, 204) Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long, TotalSum As Double Dim k As Integer, Irow As Integer, r As Long, count As Long, tbl As Double, j As Double Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub k = f.Range("G1").Value If k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i LastRow = .Cells(.Rows.count, "A").End(xlUp).Row StartRow = 2 tbl = 0 TotalSum = 0 i = StartRow Do While i <= LastRow EndRow = i + k - 1 If EndRow > LastRow Then EndRow = LastRow j = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow)) TotalSum = TotalSum + j If EndRow < LastRow Then .Rows(EndRow + 1).Insert Shift:=xlDown .Cells(EndRow + 1, "B").Value = SumRng .Cells(EndRow + 1, "E").Value = j + tbl .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor .Rows(EndRow + 2).Insert Shift:=xlDown .Cells(EndRow + 2, "B").Value = ColArr .Cells(EndRow + 2, "E").Value = j + tbl .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor tbl = j + tbl LastRow = LastRow + 2 End If i = EndRow + 3 Loop Irow = .Cells(.Rows.count, "A").End(xlUp).Row .Rows(Irow + 1).Insert Shift:=xlDown With .Cells(Irow + 1, "B") .Value = SumPages .Offset(0, 3).Value = TotalSum .Resize(1, 4).Font.Size = 18 .Parent.Range("A" & Irow + 1 & ":E" & Irow + 1).Interior.Color = xColor End With .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _ .Cells(r, 2).Value <> SumPages Then .Cells(r, 1).Value = count + 1 count = count + 1 End If Next r End With If Not CrWS Is Nothing Then Call PrintArea_data(CrWS) End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub '============================================ Sub déleteRows() Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" Dim LastRow As Long, i As Long If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub Application.ScreenUpdating = False With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i End With Application.ScreenUpdating = True End Sub '==================================== Sub PrintArea_data(CrWS As Worksheet) Dim rCount As Long, tmps As Long, i As Long Dim lastCol As Long, OnRng As Range, n As Long n = f.Range("G1").Value + 2 If n <= 0 Then Exit Sub tmps = 2 CrWS.ResetAllPageBreaks rCount = CrWS.Cells(CrWS.Rows.count, 2).End(xlUp).Row If rCount > tmps + n Then For i = tmps + n To rCount Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(1, "E").Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, 1), CrWS.Cells(rCount, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) With CrWS.PageSetup .Orientation = xlPortrait .PaperSize = xlPaperA4 .FitToPagesWide = 1 .FitToPagesTall = False End With End Sub وللتنفيد على نفس المصنف ورقة test Public Property Get CrWS() As Worksheet: Set CrWS = Sheets("test"): End Property Sub Split_Rows() Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" Dim xColor As Long: xColor = RGB(204, 255, 204) Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long Dim k As Integer, j As Integer, r As Long, count As Long Dim tbl As Double, TotalSum As Double, Irow As Double k = CrWS.Range("G1").Value If CrWS.Name <> "test" Or k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i LastRow = .Cells(.Rows.count, "A").End(xlUp).Row StartRow = 2 tbl = 0 TotalSum = 0 i = StartRow Do While i <= LastRow EndRow = i + k - 1 If EndRow > LastRow Then EndRow = LastRow Irow = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow)) TotalSum = TotalSum + Irow If EndRow < LastRow Then .Rows(EndRow + 1).Insert Shift:=xlDown .Cells(EndRow + 1, "B").Value = SumRng .Cells(EndRow + 1, "E").Value = Irow + tbl .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor .Rows(EndRow + 2).Insert Shift:=xlDown .Cells(EndRow + 2, "B").Value = ColArr .Cells(EndRow + 2, "E").Value = Irow + tbl .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor tbl = Irow + tbl LastRow = LastRow + 2 End If i = EndRow + 3 Loop j = .Cells(.Rows.count, "A").End(xlUp).Row .Rows(j + 1).Insert Shift:=xlDown With .Cells(j + 1, "B") .Value = SumPages .Offset(0, 3).Value = TotalSum .Resize(1, 4).Font.Size = 18 .Parent.Range("A" & j + 1 & ":E" & j + 1).Interior.Color = xColor End With .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _ .Cells(r, 2).Value <> SumPages Then .Cells(r, 1).Value = count + 1 count = count + 1 End If Next r End With Call PrintArea_data .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub للتنفيد على مصنف خارجي.rar تحديد عدد صفوف للصفحة ومجموعها v2.xlsm

جرب هدا بعد تنفيد ما سبق دكره سابقا 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

السلام عليكم تفضل الحل بالأكواد تضع كافة الملفات في مجلد (فولدر واحد) وتضع معهم هذا الملف suppliers.xlsm المرفق تفتخه وتضغط الزر ، يبدأ في عمل التالي فتح الملفات الواحد تلو الأخر استدعاء البيانات من الملف المفتوخ ونسخها للملف الأصلي غلق الملف المفتوخ ثم تكرار الخطوات الثلاثة ختي نهاية الملفات في الفولدر مهما كان عدد الملفات suppliers.xlsm

وهذا ملف آخر من عندي 🙂 كلمة السر : 123 يمكنك تعديلها في الكود .. ‏‏تمكين أو تعطيل زر الشفت SHIFT Enable or Disable - محمي بباسوورد.accdb

اقدم لكم برنامج حساب أيام العمل أو الاجازات بين تاريخين .......... (اختيار أيام العمل الاسبوعية + العطل الرسمية) مفتوح المصدر. . اليكم المرفق . DDDayWork.rar

وعليكم السلام ورحمة الله تعالى وبركاته ما عليك سوى تحديد الشيتات المرغوب دمجها كما في الصورة Sub Merge_worksheets() Dim Rng, C, A(), P&, i&, F&, Y&, N&, derligne&, lastrow& Dim DestArr() As String Dim ws As Worksheet: Set ws = Sheets("تجميع") lastrow = ws.Cells(Rows.Count, "a").End(xlUp).Row + 1 N = ws.Range("W" & Rows.Count).End(xlUp).Row Set Rng = ws.Range("W2:W" & N) Application.ScreenUpdating = False If ws.[V2] = Empty Then m = MsgBox("المرجوا تحديث قائمة أسماء الشيتات", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "انتباه"): Exit Sub On Error Resume Next For Each C In Rng If C Then If C <> "" Then ReDim Preserve DestArr(0 To P) DestArr(P) = C.Offset(, -1).Value P = P + 1 End If End If Next For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) For i = 1 To UBound(Rng, 1) ws.Range("A2:N" & lastrow).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Rng, 2), 1 To Y) For F = 1 To UBound(Rng, 2) A(F, Y) = Rng(i, F) Next Next With ws ws.Range("a2").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next On Error GoTo 0 ws.Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub ListSheets() Dim derligne&, x As Integer Dim ws As Worksheet: Set ws = Sheets("تجميع") derligne = ws.Cells(Rows.Count, 22).End(xlUp).Row + 1 Application.ScreenUpdating = False ws.Range("v2:v" & derligne).ClearContents x = 2 For Each WSdata In Worksheets If WSdata.Name <> ws.Name Then ws.Cells(x, 22) = WSdata.Name x = x + 1 End If Next End Sub تجميع V2.xlsm

جرب هذا الماكرو Option Explicit Sub copy_paste() Dim lr1%: lr1 = Sheets("Sheet1").Cells(Rows.Count, "D").End(3).Row + 2 lr1 = IIf(lr1 = 3, 1, lr1) Dim lr2%: lr2 = Sheets("Sheet2").Cells(Rows.Count, "D").End(3).Row Dim i%: i = 1 Dim col As Object Set col = CreateObject("System.Collections.ArrayList") With col Do Until i > lr2 If Sheets("Sheet2").Range("D" & i) <> vbNullString Then .Add Sheets("Sheet2").Range("D" & i).Value End If i = i + 1 Loop Sheets("Sheet1").Range("d" & lr1).Resize(.Count - 1) = _ Application.Transpose(.toarray) End With End Sub الملف مرفق Bookaa.xlsm

الملف مرة تانية بالمرفقات ودا الكود المتسخدم بالشرح On Error Resume Next If Range("a3") = "" Or Range("b3") = "" Or Range("c3") = "" Then MsgBox "bla bla1", vbDefaultButton1, "bla bla1 " Else azsh = Sheet2.Range("c50000").End(xlUp).Row + 1 Sheet1.Range("A3:C3").Copy Sheet2.Cells(azsh, 1).PasteSpecial Paste:=xlPasteValues MsgBox "bla bla2", vbDefaultButton1, "bla bla2 " Sheet1.Range("A3:C3") = "" End If كود ترحيل البيانات- أوفيسنا.rar