منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب
تصدير البيانات الي ملف اكسل .. ارجوا مساعدتكم - نسخة قابلة للطباعة

+- منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب (http://vb4arb.com/vb)
+-- قسم : قسم لغات البرمجة الاخرى (http://vb4arb.com/vb/forumdisplay.php?fid=4)
+--- قسم : قسم لغة vb6.0 (http://vb4arb.com/vb/forumdisplay.php?fid=18)
+--- الموضوع : تصدير البيانات الي ملف اكسل .. ارجوا مساعدتكم (/showthread.php?tid=11392)

تصدير البيانات الي ملف اكسل .. ارجوا مساعدتكم - ابومحمد1979 - 10-02-15

[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:


RE: تصدير البيانات الي ملف اكسل .. ارجوا مساعدتكم - Ashraf Elafify - 12-02-15

اخى العزيز

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

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

كود :
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


يرجى تغير ما يلزم من رؤوس الاعمدة و خلافة من بياناتى الى بياناتك.

RE: تصدير البيانات الي ملف اكسل .. ارجوا مساعدتكم - ابومحمد1979 - 17-02-15

جزاك الله خير ولاكن ماضبطت معي