تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
تصدير البيانات الي ملف اكسل .. ارجوا مساعدتكم
#1
[align=right]بسم الله الرحمن الرحيم

الاخوة الاعزاء اسعد الله مساكم اين ماكنتم  ووفقكم الي الخير

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

إقتباس :Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM actions ORDER BY ordernumber", cn, adOpenStatic, adLockOptimistic
If rs.RecordCount <= 0 Then
   MsgBox "áÇ ÊæÌÏ ÈíÇäÇÊ Ýí ÇáÞÇÚÏÉ ÇáÈíÇäÇÊ"
Else
   
   CommonDialog1.CancelError = True
   On Error GoTo ErrHandler
   
   Set xlApp = CreateObject("Excel.Application")
   xlApp.SheetsInNewWorkbook = 1
   xlApp.Visible = True
   Set xlBook = xlApp.Workbooks.Add
   xlApp.Windows(1).ActiveSheet.Name = "sheet"
   
   
   
   Set xlSheet = xlBook.Worksheets("Sheet")
   
   xlSheet.Range("B6").CopyFromRecordset rs
    xlSheet.cells(3, 3).Value = Date
    xlSheet.cells(3, 1).Value = "Report printed "


   xlSheet.cells(5, 2).columnWidth = 5
   xlSheet.cells(5, 1).columnWidth = 5

   xlSheet.cells(5, 1).Value = "Ê"
   xlSheet.cells(5, 1).columnWidth = 3
     
   xlSheet.cells(5, 2).columnWidth = 10
   xlSheet.cells(5, 2).Value = "ÇãÑ ÇáÚãá"
   
   xlSheet.cells(5, 3).columnWidth = 10
   xlSheet.cells(5, 3).Value = "ÑÞã ÇáãÎØØ"
   
   xlSheet.cells(5, 4).columnWidth = 14
   xlSheet.cells(5, 4).Value = "ãÌãæÚ ÇáãÎØØÇÊ"
   
   xlSheet.cells(5, 5).columnWidth = 10
   xlSheet.cells(5, 5).Value = "ÇáãÞÓã"
   
   xlSheet.cells(5, 6).columnWidth = 10
   xlSheet.cells(5, 6).Value = "ÇáßÈíäå"
   
   xlSheet.cells(5, 7).columnWidth = 10
   xlSheet.cells(5, 7).Value = "äæÚ ÇáÚãá"
   
   xlSheet.cells(5, 8).columnWidth = 10
   xlSheet.cells(5, 8).Value = "SITE FOC"
   
   xlSheet.cells(5, 9).columnWidth = 10
   xlSheet.cells(5, 9).Value = "RACK"
   
   xlSheet.cells(5, 10).columnWidth = 10
   xlSheet.cells(5, 10).Value = "POSTION"
   
   xlSheet.cells(5, 11).columnWidth = 10
   xlSheet.cells(5, 11).Value = "Fiber"
   
   xlSheet.cells(5, 12).columnWidth = 10
   xlSheet.cells(5, 12).Value = "Capillaries"
   
   xlSheet.cells(5, 13).columnWidth = 10
   xlSheet.cells(5, 13).Value = "NEW_DP"
   
   xlSheet.cells(5, 14).columnWidth = 10
   xlSheet.cells(5, 14).Value = "FIM"
   
   xlSheet.cells(5, 15).columnWidth = 10
   xlSheet.cells(5, 15).Value = "DP"
   
   xlSheet.cells(5, 16).columnWidth = 10
   xlSheet.cells(5, 16).Value = "BSW"
   
   xlSheet.cells(5, 17).columnWidth = 10
   xlSheet.cells(5, 17).Value = "REMARKS"
   
   xlSheet.cells(5, 18).columnWidth = 10
   xlSheet.cells(5, 18).Value = "FOC_Type"
   
   xlSheet.cells(5, 19).columnWidth = 10
   xlSheet.cells(5, 19).Value = "DB_Type"
   
   xlSheet.cells(5, 20).columnWidth = 10
   xlSheet.cells(5, 20).Value = "ÈÏÇíÉ ÇáÚãá"
   
   xlSheet.cells(5, 21).columnWidth = 10
   xlSheet.cells(5, 21).Value = "ÇÞÝÇá ÇáÚãá"
   
   xlSheet.cells(5, 22).columnWidth = 10
   xlSheet.cells(5, 22).Value = "ÇáãÞÇæá"
   
   xlSheet.cells(5, 23).columnWidth = 10
   xlSheet.cells(5, 23).Value = "ÇáãÝÊÔ"
   
   xlSheet.cells(5, 24).columnWidth = 14
   xlSheet.cells(5, 24).Value = "ÊÇÑíÎ ÊÓÌíá ÇáÚãá"
   
   xlSheet.cells(5, 25).columnWidth = 10
   xlSheet.cells(5, 25).Value = "ÍÇáÉ ÇáÚãá"
 
   xlSheet.cells(5, 26).columnWidth = 80
   xlSheet.cells(5, 26).Value = "ãáÇÍÙÇÊ"

   xlSheet.Range("a5:z5").Font.Bold = True
   
   xlSheet.cells(6, 1).Value = 1
   xlSheet.cells(7, 1).Value = 2
   
   xlSheet.Range("a6:B7").AutoFill Destination:=xlSheet.Range("a6:B" & rs.RecordCount + 5), Type:=xlLinearTrend

   xlSheet.Range("a5:z" & rs.RecordCount + 5).Borders.Weight = xlThin
   xlSheet.Range("a5:z" & rs.RecordCount + 7).Font.Size = 10
   xlSheet.Range("a5:z" & rs.RecordCount + 7).Font.Color = &H404080

   xlSheet.Range("a5:z" & rs.RecordCount + 7).Font.Name = "Times New Roman"
   xlSheet.Range("a5:z" & rs.RecordCount + 7).HorizontalAlignment = xlCenter
   xlSheet.Range("a5:z" & rs.RecordCount + 7).VerticalAlignment = xlVAlignCenter
   
   xlSheet.Range("F" & rs.RecordCount + 7).NumberFormat = "###,##0.00"
   xlSheet.Range("E" & rs.RecordCount + 7 & ":F" & rs.RecordCount + 7).Font.Bold = True
   xlSheet.Range("E" & rs.RecordCount + 7 & ":F" & rs.RecordCount + 7).Borders.Weight = xlThin
End If

ErrHandler:
الرد }}}
تم الشكر بواسطة:
#2
اخى العزيز

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

أرجوان تجد فيه ما تسأل عنه.

كود :
Private Sub Export_Click()
On Error Resume Next
  Dim Anas As Object
  Dim Abbas As Object
  Dim Eidan As Object
  Set Anas = CreateObject("Excel.Application")
  Set Abbas = Anas.Workbooks.Add
     Dim DataArray(1 To 20000, 1 To 30) As Variant
     Dim r As Integer
     Dim NumberOfRows As Integer
     NumberOfRows = Data1.Recordset.RecordCount
     Data1.Recordset.MoveFirst
'ÃÓãÇÁ ÇáÍÞæá
     For r = 1 To NumberOfRows
               DataArray(r, 1) = Data1.Recordset.Fields("ID")
               DataArray(r, 2) = Data1.Recordset.Fields("MaintenanceManagerPriority")
               DataArray(r, 3) = Data1.Recordset.Fields("LOTO")
               DataArray(r, 4) = Data1.Recordset.Fields("MAINTENANCE_SECTION")
               DataArray(r, 5) = Data1.Recordset.Fields("TSS")
               DataArray(r, 6) = Data1.Recordset.Fields("Work_Type")
               DataArray(r, 7) = Data1.Recordset.Fields("Work_Description")
               DataArray(r, 8) = Data1.Recordset.Fields("WC_Section_Code")
               DataArray(r, 9) = Data1.Recordset.Fields("Lines")
               DataArray(r, 10) = Data1.Recordset.Fields("Status")
               DataArray(r, 11) = Data1.Recordset.Fields("EBR")
               DataArray(r, 12) = Data1.Recordset.Fields("Date_Of_Request")
               DataArray(r, 13) = Data1.Recordset.Fields("Time_Of_Request")
               DataArray(r, 14) = Data1.Recordset.Fields("Issuing_Department")
               DataArray(r, 15) = Data1.Recordset.Fields("Issuing_Person")
               DataArray(r, 16) = Data1.Recordset.Fields("Request_Origin")
               DataArray(r, 17) = Data1.Recordset.Fields("Request_Reference")
               DataArray(r, 18) = Data1.Recordset.Fields("Work_Purpose")
               DataArray(r, 19) = Data1.Recordset.Fields("Timing")
               DataArray(r, 20) = Data1.Recordset.Fields("PRIORITY")
               DataArray(r, 21) = Data1.Recordset.Fields("Date_Of_Start")
               DataArray(r, 22) = Data1.Recordset.Fields("Requested_Comp_Date")
               DataArray(r, 23) = Data1.Recordset.Fields("Requested_Comp_Week")
               DataArray(r, 24) = Data1.Recordset.Fields("Requested_Comp_Time")
               DataArray(r, 25) = Data1.Recordset.Fields("PRS")
               DataArray(r, 26) = Data1.Recordset.Fields("ITEM")
               DataArray(r, 27) = Data1.Recordset.Fields("Est_Material_Approval_Date")
               DataArray(r, 28) = Data1.Recordset.Fields("Estimated_Duration")
               DataArray(r, 29) = Data1.Recordset.Fields("shift")
               DataArray(r, 30) = Data1.Recordset.Fields("Remarks")
     Data1.Recordset.MoveNext
     Next
  Set Eidan = Abbas.Worksheets(1)
  Eidan.Range("A1:AD1").Font.Bold = True
'   ÚäÇæíä ÇáÍÞæá
  Eidan.Range("A1:AD1").Value = Array("Id", "Maintenance Manager Priority", "Loto", "Maintenance Section", "TSS", "Work Type", "Work Description", "Wc Section Code", "Lines", "Status", "EBR", "Date Of Request", "Time Of Request", "Issuing Department", "Issuing Person", "Request Origin", "Request Reference", "Work Purpose", "Timing", "Priority", "Date Of Start", "Requested Comp. Date", "Requested Comp. Week", "Requested Comp Time", "PRS", "Item", "Est. Material Approval Date", "Est. Duration", "Shift", "Remarks")                             ' Put Headers Of Fields To Excel File
  Eidan.Range("A2").Resize(NumberOfRows, 30).Value = DataArray
  Abbas.SaveAs App.Path & "\AshrafElafify.xls"
  Anas.Quit
  Data1.Recordset.MoveFirst
  MsgBox "Complete...", 64, "Info"
End Sub


يرجى تغير ما يلزم من رؤوس الاعمدة و خلافة من بياناتى الى بياناتك.
لا اله الا انت سبحانك انى كنت من الظالمين.
اللهم انك عفو كريم حليم تحب العفو فاعفوا عنا.
اللّهُمَّ اغْفِرْ لِي وَلِوالِدَيَّ وَارْحَمْهُما كَما رَبَّيانِي صَغِيراً، اللَّهُمَّ اجْزِهِما بِالاِحْسانِ إِحْسانا وَبِالسَّيِّئاتِ غُفْرانا، اللَّهُمَّ اغْفِرْ لِلْمُؤْمِنينَ وَالمُؤْمِناتِ الاَحْياءِ مِنْهُمْ وَالاَمْواتِ.
سبحان الله والحمدلله ولا إله إلا الله والله أكبر زنه عرشك ومداد كلماتك ورضاء نفسك وكما ينبغى لجلال شأنك وعظيم سلطانك وعدد ما كان وعدد ما سيكون وعدد الحركات و السكون وعدد ما نعلم وعدد مالانعلم وعدد كل شيئ احصيته بعلمك يا كريم
الرد }}}
تم الشكر بواسطة: ابومحمد1979
#3
جزاك الله خير ولاكن ماضبطت معي
الرد }}}
تم الشكر بواسطة:


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  اضافة الصور الى ملف واسترجاعها بدون قاعدة البيانات haitham Muhammed 0 375 21-01-24, 12:58 PM
آخر رد: haitham Muhammed
  [vb6.0] تصدير البيانات محمد عياش 0 470 12-12-22, 07:10 PM
آخر رد: محمد عياش
  مشكلة الللغة العربية في تصدير اكتيف ريبورت الى PDF hannileo 3 731 25-10-22, 02:03 PM
آخر رد: hannileo
  بخصوص صيغة التاريخ عند الحفظ في قاعدة البيانات hannileo 0 551 03-07-22, 12:19 PM
آخر رد: hannileo
  [سؤال] كيفية استيراد ملف اكسل الى قاعدة بيانات اكسس في فيجوال 6 sher 14 8,480 14-06-22, 04:01 PM
آخر رد: sher
  [vb6.0] طلب : كود عرض نص معين من قاعدة البيانات وعرضه في label في داتا ريبورت hamada salah90 3 1,561 26-07-21, 06:43 PM
آخر رد: hamada salah90
  [vb6.0] استرداد ملف اكسل mahtawfik 0 798 07-07-21, 05:07 PM
آخر رد: mahtawfik
  [vb6.0] أريد شرح مبسط وواضح للعلاقات بين جداول قاعدة البيانات وشرح الإستعلامات بهذه العلاقات hamada salah90 0 1,006 01-06-21, 02:12 AM
آخر رد: hamada salah90
  عندي مشكلة وهي عند تصدير ملف إكسل rami_cis 0 1,098 16-12-20, 12:28 AM
آخر رد: rami_cis
  [vb6.0] مشكل في ادخال البيانات من البارتاج lkjnfg 0 1,087 26-10-20, 10:03 PM
آخر رد: lkjnfg

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم