Prikazi cijelu temu 30.09.2011 19:49
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Lokacija:Tuzla


Predmet:Re: export podataka iz pivot access u excel tabelu
Jeli ovo?
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.Range(Kolona).Rows(Red).MergeCells = True
  34. ExcelSheet.Application.Cells(Red - 1, Kolona).Value = Podatak
  35. PodatakPrije = Podatak
  36. Podatak = "Kut"
  37. ExcelSheet.Application.Cells(Red, Kolona).Value = Podatak
  38. Podatak = "Pod"
  39. ExcelSheet.Application.Cells(Red, Kolona).Value = Podatak
  40. End If
  41. RsSort.MoveNext
  42. Loop
  43.  
  44. Rs.MoveFirst
  45. Do While Not Rs.EOF
  46. Podatak = Rs.Fields(1)
  47. If Podatak <> PodatakPrije Then
  48. Red = Red + 1
  49. ExcelSheet.Application.Cells(Red, 1).Value = Podatak
  50. Podatak = Rs.Fields(2)
  51. ExcelSheet.Application.Cells(Red, 2).Value = Podatak
  52. Podatak = Rs.Fields(3)
  53. ExcelSheet.Application.Cells(Red, 3).Value = Podatak
  54. Podatak = Rs.Fields(1)
  55. PodatakPrije = Podatak
  56. End If
  57. For X = 4 To Kolona Step 2
  58. If KolS(X) = Rs!Rel Then
  59. Podatak = Rs.Fields(5)
  60. ExcelSheet.Application.Cells(Red, X).Value = Podatak
  61. Podatak = Rs.Fields(6)
  62. ExcelSheet.Application.Cells(Red, X + 1).Value = Podatak
  63. End If
  64. Next X
  65. Rs.MoveNext
  66. Loop
  67. ExcelSheet.Application.Cells.EntireColumn.AutoFit
  68. Red = 1
  69. Kolona = 1
  70. Rs.MoveFirst
  71. Podatak = Rs.Fields(0)
  72. ExcelSheet.Application.Cells(Red, Kolona).Value = "PREGLED NA DAN " & Podatak
  73. ExcelSheet.Application.Visible = True
  74. OtvoriExcel_izl:
  75. Exit Function
  76. OtvoriExcel_err:
  77. MsgBox "Došlo je do greške", 48, "Greska"
  78. Resume OtvoriExcel_izl
  79. End Function
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.