Prikazi cijelu temu 29.09.2011 22:12
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Lokacija:Tuzla


Predmet:Re: export podataka iz pivot access u excel tabelu
Evo doradjena procedura.
Nemoras praviti novu formu za poziv procedure.
Mozes napraviti tul bar i vezati ga za ovu pivot formu pa kad se podigne pivot forma podigne se i tul bar.
Na tul baru jednu custom comand taster.
Na on action samo upisi OtvoriExcel tj. ime procedure.
Ako ne uspijes postavit cu ti primjer.
Bolje je da sam to odradis.
Ovu proceduru kopiraj u neki modul a staru pobrisi.
PreuzmiIzvorni kôd (Visual Basic):
  1. Option Compare Database
  2. Option Explicit
  3. Global ExcelSheet As Object
  4. Function OtvoriExcel()
  5. Dim Db As Database
  6. Dim Rs As Recordset
  7. Dim RsSort As Recordset
  8. Dim Podatak, PodatakPrije
  9. Dim Red As Integer, Kolona As Integer
  10. Dim KolS() As String
  11. Dim X As Integer, N As Integer
  12.  
  13.  
  14. On Error GoTo OtvoriExcel_err
  15. 'PODACI IZ ACCESSA
  16.  
  17. Set Db = CurrentDb
  18. Dim a, b
  19. Set Rs = Forms![frm_Davor].RecordsetClone
  20. Set ExcelSheet = CreateObject("Excel.Sheet")
  21. Red = 3
  22. ExcelSheet.Application.Cells(Red, 1).Value = "Å ifra"
  23. ExcelSheet.Application.Cells(Red, 2).Value = "Naziv"
  24. ExcelSheet.Application.Cells(Red, 3).Value = "Kom."
  25. Kolona = 2
  26. Rs.Sort = "Rel"
  27. Set RsSort = Rs.OpenRecordset()
  28. X = Rs.RecordCount
  29. ReDim KolS(X + 3)
  30. RsSort.MoveFirst
  31. Do While Not RsSort.EOF
  32. Podatak = RsSort.Fields("Rel")
  33. If Podatak <> PodatakPrije Then
  34. Kolona = Kolona + 2
  35. KolS(Kolona) = Podatak
  36. 'ExcelSheet.Application.Range(Kolona).Rows(Red).MergeCells = True
  37. ExcelSheet.Application.Cells(Red, Kolona).Value = Podatak
  38. PodatakPrije = Podatak
  39. End If
  40. RsSort.MoveNext
  41. Loop
  42.  
  43. Rs.MoveFirst
  44. Do While Not Rs.EOF
  45. Podatak = Rs.Fields(1)
  46. If Podatak <> PodatakPrije Then
  47. Red = Red + 1
  48. ExcelSheet.Application.Cells(Red, 1).Value = Podatak
  49. Podatak = Rs.Fields(2)
  50. ExcelSheet.Application.Cells(Red, 2).Value = Podatak
  51. Podatak = Rs.Fields(3)
  52. ExcelSheet.Application.Cells(Red, 3).Value = Podatak
  53. Podatak = Rs.Fields(1)
  54. PodatakPrije = Podatak
  55. End If
  56. For X = 4 To Kolona Step 2
  57. If KolS(X) = Rs!Rel Then
  58. Podatak = Rs.Fields(5)
  59. ExcelSheet.Application.Cells(Red, X).Value = Podatak
  60. Podatak = Rs.Fields(6)
  61. ExcelSheet.Application.Cells(Red, X + 1).Value = Podatak
  62. End If
  63. Next X
  64. Rs.MoveNext
  65. Loop
  66. ExcelSheet.Application.Cells.EntireColumn.AutoFit
  67. Red = 1
  68. Kolona = 1
  69. Rs.MoveFirst
  70. Podatak = Rs.Fields(0)
  71. ExcelSheet.Application.Cells(Red, Kolona).Value = "PREGLED NA DAN " & Podatak
  72. ExcelSheet.Application.Visible = True
  73. OtvoriExcel_izl:
  74. Exit Function
  75. OtvoriExcel_err:
  76. MsgBox "Došlo je do greške", 48, "Greska"
  77. Resume OtvoriExcel_izl
  78. End Functio
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.
Ovaj post je ureden 1 puta. Posljednja izmjena 29.09.2011 22:14 od strane zxz.