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

اين بدايتك انت ... جداولك .... حتى نرى ما المطلوب ... ابدأ وسوف تجد الاجابات من مرتادي المنتدى ... ابشر

السلام عليكم ورحمة الله وبركاته اليك ما طلبت جدول التفريغ22.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub test() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("التقرير") If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:E").ClearContents On Error GoTo 0 dest.Range("A1").Resize(1, 5).Value _ = Array("الشهر", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr m = Trim(WS.Cells(i, "M").Text) If m <> "" Then If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) a = d(m) a(0) = a(0) + 1: a(1) = a(1) + tmp(WS.Cells(i, "S").Value) a(2) = a(2) + tmp(WS.Cells(i, "U").Value): a(3) = a(3) + tmp(WS.Cells(i, "F").Value) d(m) = a End If Next i Next WS For Each k In d.Keys a = d(k) dest.Cells(r, 1).Resize(1, 5).Value = Array(k, a(0), a(1), a(2), a(3)) r = r + 1 Next k .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير بنجاح", vbInformation End Sub Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function تقرير من شيتين v2.xlsm

استبدل الدالة القديمة ، بالدالة التالية ، Private Sub AddToTempSelected() On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSQL As String Dim anneeValue As Variant Dim gradeValue As Variant Dim wilayaValue As Variant Dim existingWilaya As String Dim wilayaArray As Variant Dim wilayaExists As Boolean Dim i As Integer Dim currentYear As Integer Dim previousYear As Integer Set db = CurrentDb() currentYear = Me.ANNEE3.Column(0) previousYear = currentYear - 1 anneeValue = previousYear & "/" & currentYear gradeValue = Me.GRADE3.Column(0) wilayaValue = Trim(Me.lst_XX.Column(0)) strSQL = "SELECT wilaya FROM temp_selected " & _ "WHERE annee = '" & Replace(anneeValue, "'", "''") & "' " & _ "AND grade = '" & Replace(gradeValue, "'", "''") & "'" Set rs = db.OpenRecordset(strSQL) If Not rs.EOF Then existingWilaya = Nz(rs!wilaya, "") If existingWilaya <> "" Then wilayaArray = Split(existingWilaya, " - ") wilayaExists = False For i = LBound(wilayaArray) To UBound(wilayaArray) If Trim(wilayaArray(i)) = wilayaValue Then wilayaExists = True Exit For End If Next i If Not wilayaExists Then If existingWilaya <> "" Then existingWilaya = existingWilaya & " - " & wilayaValue Else existingWilaya = wilayaValue End If strSQL = "UPDATE temp_selected SET wilaya = '" & Replace(existingWilaya, "'", "''") & "' " & _ "WHERE annee = '" & Replace(anneeValue, "'", "''") & "' " & _ "AND grade = '" & Replace(gradeValue, "'", "''") & "'" db.Execute strSQL, dbFailOnError End If Else strSQL = "UPDATE temp_selected SET wilaya = '" & Replace(wilayaValue, "'", "''") & "' " & _ "WHERE annee = '" & Replace(anneeValue, "'", "''") & "' " & _ "AND grade = '" & Replace(gradeValue, "'", "''") & "'" db.Execute strSQL, dbFailOnError End If Else strSQL = "INSERT INTO temp_selected (annee, grade, wilaya) " & _ "VALUES ('" & Replace(anneeValue, "'", "''") & "', '" & Replace(gradeValue, "'", "''") & "', '" & Replace(wilayaValue, "'", "''") & "')" db.Execute strSQL, dbFailOnError End If CleanUp: If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء محاولة تحديث البيانات", vbCritical + vbMsgBoxRight, "خطأ" Resume CleanUp End Sub حيث سيتم تخزين القيمة في الجدول مباشرة بالتنسيق الذي تريده ( السنة التي تم اختيارها = 2025 ، سيتم تخزينها = 2024 / 2025 في الحقل بعد ان تم تغيير نوعه الى حقل نصي ) BASE_e.accdb

بأقرب فرصة إن شاء الله 😇 .

هل البيانات المنقولة باللغة الانجليزية ام العربية وهل ممكن مرفق كمثال للتطبيق عليه

Try #If VBA7 Then Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr #Else Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long #End If Function CreateElevatedFile(ByVal sFilePath As String, ByVal sFileContent As String) As Boolean On Error GoTo ErrorHandler Dim fso As Object, sScriptPath As String, psScript As String, EscFilePath As String, EscContent As String sScriptPath = Environ("TEMP") & "\create_elevated_file.ps1" EscFilePath = Replace(Replace(sFilePath, "'", "''"), """", "\""") EscContent = Replace(Replace(sFileContent, "'", "''"), """", "\""") psScript = "$t = [System.Diagnostics.ProcessWindowStyle]::Hidden;$p = Start-Process -WindowStyle $t -FilePath 'powershell.exe' -ArgumentList '-Command ""Set-Content -Path \""" & EscFilePath & "\""` -Value \""" & EscContent & "\""""' -Verb RunAs -PassThru;$p.WaitForExit();Exit $p.ExitCode" Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(sScriptPath, True) .WriteLine psScript .Close End With ShellExecute 0, "runas", "powershell.exe", "-ExecutionPolicy Bypass -WindowStyle Hidden -File """ & sScriptPath & """", vbNullString, 0 CreateElevatedFile = True Exit Function ErrorHandler: CreateElevatedFile = False End Function Sub Create_File_With_Elevated_Permissions() Dim success As Boolean success = CreateElevatedFile("C:\Windows\Test.txt", "This Was Created With Elevated Permissions") If success Then MsgBox "File Created Successfully", vbInformation Else MsgBox "File Not Created", vbExclamation End If End Sub