Prikazi cijelu temu 28.09.2011 16:47
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Lokacija:Tuzla


Predmet:Re: export podataka iz pivot access u excel tabelu
Evo.
Proceduru moras pozvati sa forme pivot.
Naime forma mora biti otvorena radi uslova koji si stavio.
PreuzmiIzvorni kôd (Visual Basic):
  1. Function OtvoriExcel()
  2. Dim Db As Database
  3. Dim Rs As Recordset
  4. Dim RsSort As Recordset
  5. Dim Podatak, PodatakPrije
  6. Dim Red As Integer, Kolona As Integer
  7. Dim KolS() As String
  8. Dim X As Integer, N As Integer
  9.  
  10.  
  11. 'On Error GoTo OtvoriExcel_err
  12. 'PODACI IZ ACCESSA
  13.  
  14. Set Db = CurrentDb
  15. Dim a, b
  16. Set Rs = Forms![frm_Davor].RecordsetClone
  17. Set ExcelSheet = CreateObject("Excel.Sheet")
  18. Red = 3
  19. ExcelSheet.Application.Cells(Red, 1).Value = "Å ifra"
  20. ExcelSheet.Application.Cells(Red, 2).Value = "Naziv"
  21. ExcelSheet.Application.Cells(Red, 3).Value = "Kom."
  22. Kolona = 2
  23. Rs.Sort = "Rel"
  24. Set RsSort = Rs.OpenRecordset()
  25. X = Rs.RecordCount
  26. ReDim KolS(X + 3)
  27. RsSort.MoveFirst
  28. Do While Not RsSort.EOF
  29. Podatak = RsSort.Fields("Rel")
  30. If Podatak <> PodatakPrije Then
  31. Kolona = Kolona + 2
  32. KolS(Kolona) = Podatak
  33. ExcelSheet.Application.Cells(Red, Kolona).Value = Podatak
  34. PodatakPrije = Podatak
  35. End If
  36. RsSort.MoveNext
  37. Loop
  38.  
  39. Rs.MoveFirst
  40. Do While Not Rs.EOF
  41. Red = Red + 1
  42. Podatak = Rs.Fields(1)
  43. ExcelSheet.Application.Cells(Red, 1).Value = Podatak
  44. Podatak = Rs.Fields(2)
  45. ExcelSheet.Application.Cells(Red, 2).Value = Podatak
  46. Podatak = Rs.Fields(3)
  47. ExcelSheet.Application.Cells(Red, 3).Value = Podatak
  48. For X = 4 To Kolona Step 2
  49. If KolS(X) = Rs!Rel Then
  50. Podatak = Rs.Fields(5)
  51. ExcelSheet.Application.Cells(Red, X).Value = Podatak
  52. Podatak = Rs.Fields(6)
  53. ExcelSheet.Application.Cells(Red, X + 1).Value = Podatak
  54. End If
  55. Next X
  56. Rs.MoveNext
  57. Loop
  58. ExcelSheet.Application.Cells.EntireColumn.AutoFit
  59. Red = 1
  60. Kolona = 1
  61. Rs.MoveFirst
  62. Podatak = Rs.Fields(0)
  63. ExcelSheet.Application.Cells(Red, Kolona).Value = "PREGLED NA DAN " & Podatak
  64. ExcelSheet.Application.Visible = True
  65. OtvoriExcel_izl:
  66. Exit Function
  67. OtvoriExcel_err:
  68. MsgBox "Došlo je do greške", 48, "Greska"
  69. Resume OtvoriExcel_izl
  70. End Function
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.