ahmed_204079

اشكرك اخي الفاضل Barna علي مشاركتك الجميلة واللي اعتقد انها انهت الجدال في هذا الموضوع ولكن اين المرفق اما موضوع اهفاء تكرار البيانات فسوف اجد له حلا وشكرا مره اخري لمجهودك

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

الله ينور عليك لكن ممكن شرح للطريقة

اولا: ارسل كل الشكر للقائمين وادارة المنتدي في مساعدتي علي حذف الموضوع السابق لكم جزيل الشكر ثانيا:عندي تقرير عن ميزانية مدرسة بكل مدرسة عدد من المعلمين اريد عدم تكرار البيانات المتشابه للمدرسة الواحده مرفق ملف الميزانية ملف بسيط (1).accdb

'تصدير الي ملف الاكسيل On Error GoTo err_cmd_Export_NEW_Click Dim db As DAO.Database Dim QDF2 As DAO.QueryDef Dim i As Integer Dim str_Sql As String, strWhere As String Dim i_strSql As String Dim i_strWorkBook As String Dim i_strCellRef As String Dim i_strWorkSheet As String Dim i_strSaveAs As String '***************************** 'Set db = CurrentDb() If SearchListEXp.ItemsSelected.Count = 0 Or ListFields.ItemsSelected.Count = 0 Then Beep MsgBox "اختر الحقول مراد تصديرهم من خلال اختيار الجدول ثم اختيار الحقل", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "تنبيه" Exit Sub End If DoCmd.DeleteObject acQuery, "qryMyQuery" '========================================================================QDF2 str_Sql = "SELECT QForExport.* FROM QForExport " strWhere = "Where a1 IN( " For i = 0 To SearchListEXp.ListCount - 1 If SearchListEXp.Selected(i) Then strWhere = strWhere & "'" & SearchListEXp.Column(0, i) & "', " End If Next i strWhere = Left(strWhere, Len(strWhere) - 2) & ");" str_Sql = str_Sql & strWhere Set QDF2 = CurrentDb.CreateQueryDef("qryMyQuery", str_Sql) '======================================================================== 'check if Table or Query are selected If Len(Me.cmb_TQ & "") = 0 Then MsgBox "Please select Table or Query" Me.cmb_TQ.SetFocus Exit Sub End If 'check if Table or Query Name is selected If Len(Me.cmb_TQ & "") = 0 Then MsgBox "Please select Table or Query Name" Me.cmb_TQ.SetFocus Exit Sub End If 'check if Table or Query Name is selected If Len(Me.cmb_SaveFormat & "") = 0 Then MsgBox "Please select which Save Format you want to use" Me.cmb_SaveFormat.SetFocus Exit Sub End If i_strSql = i_strSql & str_Sql If Me.cmb_SaveFormat = 42 Then i_strWorkBook = Me.cmb_File_Name & Nz(Me.cmb_SaveFormat.Column(1), ".xls") Else i_strWorkBook = Me.cmb_File_Name End If i_strWorkSheet = Nz(Me.cmb_Sheet_Name, "") i_strCellRef = Nz(Me.cmb_Upper_Left_cell, "") i_strSaveAs = Nz(Me.cmb_SaveFormat, "") Call CopyRs2Sheet(i_strSql, i_strWorkBook, _ i_strWorkSheet, _ i_strCellRef, _ i_strSaveAs, _ Me.frm_Auto_Fit, _ Me.frm_Delete_Exisiting_File, _ Me.Open_The_File_on_Completion) Beep MsgBox "لقد تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "عملية تصدير البيانات" 'DoCmd.Close 'DoCmd.OpenForm "Search", acNormal Exit Sub err_cmd_Export_NEW_Click: If Err.Number = 53 Then 'file not found Resume Next ElseIf Err.Number = 2450 Then MsgBox Err.Number & vbCrLf & Err.Description DoCmd.Hourglass False Exit Sub Else MsgBox Err.Number & vbCrLf & Err.Description End If 'DoCmd.DeleteObject acQuery, "qryMyQuery" End Sub Public Sub CopyRs2Sheet(strSql As String, strWorkBook As String, _ Optional strWorkSheet As String, _ Optional strCellRef As String, _ Optional strSaveAs As String, _ Optional strAutofit As Integer, _ Optional strDeleteOriginal As Integer, _ Optional strOpenTheFile As Integer) 'Copied from: 'http://www.pcreview.co.uk/forums/export-data-specific-field-excel-possible-t1667759.html ' 'modified by jjafferr on Sep 18th 2014 ' 'Uses the Excel CopyFromRecordset method 'strSql: Sql Select string 'strWorkBook: Full path and name to target wb, will create if doesn't exist 'strWorkSheet: Name of target worksheet, will create if doesn't exist 'strCellRef: Upper Left cell for data, defaults to A1 On Error GoTo ProcError DoCmd.Hourglass True 'using late binding on Excel Dim objXLApp As Object 'Excel.Application Dim objXLWb As Object 'Excel.Workbook Dim objXLSheet As Object 'Excel.Worksheet Dim objXLCell As Object 'Excel.Range Dim rs As DAO.Recordset Dim fld As DAO.field Dim i As Integer Dim j As Integer Dim iSheets As Integer Dim Last_Dot As String Dim File_Name As String Dim A_strCellRef As String Dim N_strCellRef As Integer Dim strCellRef_Plus_One As String 'Delete the old queryDef , if exists 'DoCmd.DeleteObject acQuery, "NewQueryDef" 'delete the old file If strDeleteOriginal = 2 Then 'Delete ALL files with the same name, regardless of extension 'Last_Dot = InStrRev(strWorkBook, ".") 'File_Name = Mid(strWorkBook, 1, Len(strWorkBook) - Len(Mid(strWorkBook, Last_Dot))) 'Kill File_Name & ".*" 'Delete the file with this extension only Kill strWorkBook & ".*" End If 'set rs from sql, table or query Set rs = CurrentDb.OpenRecordset(strSql, dbOpenSnapshot) 'start Excel Set objXLApp = CreateObject("Excel.Application") 'only create workbooks with 1 sheet iSheets = objXLApp.SheetsInNewWorkbook 'save user's setting objXLApp.SheetsInNewWorkbook = 1 'set for only 1 sheet Set objXLWb = objXLApp.Workbooks.Open(strWorkBook) objXLApp.SheetsInNewWorkbook = iSheets 'restore user's setting 'select a worksheet, if sheet doesn't exist If strWorkSheet = "" Then strWorkSheet = "Sheet1" End If 'If Range is missing default to A1 If strCellRef = "" Then strCellRef = "A1" End If 'Save Format If strSaveAs = "" Then strSaveAs = "xls" End If 'select desired worksheet حدد ورقة العمل المطلوبة Set objXLSheet = objXLWb.Worksheets(strWorkSheet) 'Separate the Alpha from the Numeric in the strCellRefافصل الحروف عن الارقام For i = 1 To Len(strCellRef) If IsNumeric(Mid(strCellRef, i, 1)) = True Then GoTo Got_Numeric Next i Got_Numeric: A_strCellRef = Mid(strCellRef, 1, i - 1) 'Alpha part N_strCellRef = Mid(strCellRef, i) 'Numeric part '------------------------------------------------------------------------ 'Dose the user want the field names, their captions, or none نسخ الحقول او العناوين لملف الاكسيل 'With Field Names If Me.frm_Field_Names = 1 Then Set objXLCell = objXLSheet.Range(strCellRef) For i = 0 To rs.Fields.Count - 1 objXLCell(, i + 1) = rs.Fields(i).Name Next i strCellRef_Plus_One = A_strCellRef & Val(N_strCellRef) + 1 '------------------------------------------------------------------------ 'With Field Captions ElseIf Me.frm_Field_Names = 2 Then Set objXLCell = objXLSheet.Range(strCellRef) For i = 0 To rs.Fields.Count - 1 objXLCell(, i + 1) = rs.Fields(i).Properties("Caption") rs.MoveFirst i = 1 Do While Not rs.EOF For j = 0 To rs.Fields.Count - 1 objXLCell.Cells(i, j + 1).Value = rs(j) Next j i = i + 1 rs.MoveNext Loop Next i With objXLCell .Font.Bold = True .Font.Size = 16 .Interior.Color = RGB(255, 255, 0) .HorizontalAlignment = -4108 End With With objXLCell.Range(objXLCell.Cells(7, 2), objXLCell.Cells(i - 1, rs.Fields.Count)) .Font.Size = 14 .Font.Bold = True .HorizontalAlignment = -4108 .Borders.LineStyle = 1 End With strCellRef_Plus_One = A_strCellRef & Val(N_strCellRef) + 1 '------------------------------------------------------------------------ 'Without Field Names ElseIf Me.frm_Field_Names = 3 Then strCellRef_Plus_One = strCellRef End If '------------------------------------------------------------------------- 'insert recordset into Excel Worksheet using CopyFromRecordset method نسخ البيانات لملف الاكسيل objXLSheet.Range(strCellRef_Plus_One).CopyFromRecordset rs '-------------------------------------------------------------------------- 'Auto fit If strAutofit = 1 Then objXLSheet.Columns.AutoFit End If objXLWb.Save objXLWb.Close 'close up other rs objects If Not rs Is Nothing Then rs.Close Set rs = Nothing 'clear memory Set objXLSheet = Nothing Set objXLWb = Nothing 'quit Excel If Not objXLApp Is Nothing Then objXLApp.Quit Set objXLApp = Nothing DoCmd.Hourglass False 'Shall we open the file after creation If strOpenTheFile = 1 Then 'Application.FollowHyperlink i_strWorkBook Call fHandleFile(strWorkBook, WIN_NORMAL) End If Exit Sub ProcError: Select Case Err Case 7874 'could not find QueryDef Resume Next Case 9 'Worksheet doesn't exist objXLWb.Worksheets.Add Set objXLSheet = objXLWb.ActiveSheet objXLSheet.Name = strWorkSheet Resume Next Case 1004 'Workbook doesn't exist, make it objXLApp.Workbooks.Add Set objXLWb = objXLApp.ActiveWorkbook objXLWb.SaveAs strWorkBook, FileFormat:=strSaveAs Resume Next Case 53 'file not found Resume Next Case 3270 'Field Caption not found, use field name objXLCell(, i + 1) = rs.Fields(i).Name Resume Next Case 3061 'too few parameters, expected 1 or more 'this error occurs when trying to run a query which needs its parameters from a Form, 'the Form should be open with the parameter, then this code take the values properly Dim qdf As QueryDef Dim prm As Parameter 'Set qdf = CurrentDb.QueryDefs("strSql") Set qdf = CurrentDb.CreateQueryDef("NewQueryDef", strSql) For Each prm In qdf.Parameters prm.Value = Eval(prm.Name) Next prm Set rs = qdf.OpenRecordset(dbOpenDynaset) DoCmd.DeleteObject acQuery, "NewQueryDef" Resume Next Case Else DoCmd.Hourglass False MsgBox Err.Number & " " & Err.Description Exit Sub Resume 0 End Select End Sub

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

بارك الله فيك وجزاكم الله خيرا ولكن الرجاء التطبيق علي المثال المرفق الميزانية ملف بسيط.accdb

السلام عليكم اريد من السادة الخبراء مساعدتي في اخراج ملف الاكسيل منسق حجم الخط 14 سميك توسيط الكل العنواين 16 والخلفية صفراء يبداء التنسيق حسب التحديد من خانة cmb_Upper_Left_cell طبعا مع الاطار السميك مرفق ملف للتطبيق عليه وشكرا مقدما الميزانية ملف بسيط.accdb

اتفضل ملف مدرج به الكود بتاعك ويوجد حطا لما الغي الوظيفة من القائمة الاولي بعد ما اكون اخترت معلم اول ا مثلا يظهر لي مربع به b0 الميزانية ملف بسيط.accdb

متشكر اولا علي سرعة الرد جزاكم الله خير ثانيا هو حقل واحد باسم b0 والتسمية بتاعته الوظيفة ولا يوجد اي حقول اخري في نفس الجدول او الاستعلام QForExport بهئا الاسم يعني عير مكرر الشء اللي ارغب في نوضيحة هو اني باختار من كمبوبوكس " معلم - معلم اول - معلم اول ا- معلم خبير- كبير معلمين " فاذاكان الحقل b0(الوظيفة) غير موجود بالاستعلام يعطي رسالة ان الحقل غير مضاف ويخرج من الاجراء لحين اضافة الحقل للاستعلام من listbox الاستاذ محمد احمد لطفي متشكر جدا علي ردك ولكن لم ينجح الامر وبيعطي رسالة موجوده فيNew Bitmap image.bmpNew Bitmap image.bmpNew Bitmap image.bmp المرفقات

'الاستعلام عن حقل ان كان موجود If QForExport.b0 < 1 Then Beep MsgBox "الحقل المرد الاستعلام عنه(الوظيفة)غير موجود " Exit Sub End If الكود ده مش عاوز يشتعل معاايا فاين الخطا QForExport ده اسم الاستعلام b0 اسم الحقل

برافوا عليك ياهندسة البرمجة اشتغلت الله ينور ومتشكر علي تعبك ومجهودك

متشكر اخي الكريم بارك الله فيك هجرب واشوف

محتاج كود لنسخ بيانات حقل الي حقل اخر في نفس الجدول اسم الجدول DATA_TECH اسم الحقل المراد النسخ منه a1 اسم الحقل المراد النسخ اليه a6 مع اضافة جملة qena1.moe.edu.gov.eg@

من اقوال ابوجودي قد لا أكون قد لا أكون الأجمل.. قد لا أكون الأروع.. قد لا أكون الأذكى.. قد لا أكون الأبرع.. ولكن إذا جائنى المهموم أسمع.. وإذا نادنى صاحب الحاجه أنفع.. وحتى إذا حصدت شوكا فسأظل للورد أزرع.. وإذا ماكان الكون واسعا لكم فإن قلبى أوسع..