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):Option Compare Database
Option Explicit
Global ExcelSheet As Object
Function OtvoriExcel()
Dim Db As Database
Dim Rs As Recordset
Dim RsSort As Recordset
Dim Podatak, PodatakPrije
Dim Red As Integer, Kolona As Integer
Dim KolS() As String
Dim X As Integer, N As Integer
On Error GoTo OtvoriExcel_err
'PODACI IZ ACCESSA
Set Db = CurrentDb
Dim a, b
Set Rs = Forms![frm_Davor].RecordsetClone
Set ExcelSheet = CreateObject("Excel.Sheet")
Red = 3
ExcelSheet.Application.Cells(Red, 1).Value = "Ć ifra"
ExcelSheet.Application.Cells(Red, 2).Value = "Naziv"
ExcelSheet.Application.Cells(Red, 3).Value = "Kom."
Kolona = 2
Rs.Sort = "Rel"
Set RsSort = Rs.OpenRecordset()
X = Rs.RecordCount
ReDim KolS(X + 3)
RsSort.MoveFirst
Do While Not RsSort.EOF
Podatak = RsSort.Fields("Rel")
If Podatak <> PodatakPrije Then
Kolona = Kolona + 2
KolS(Kolona) = Podatak
'ExcelSheet.Application.Range(Kolona).Rows(Red).MergeCells = True
ExcelSheet.Application.Cells(Red, Kolona).Value = Podatak
PodatakPrije = Podatak
End If
RsSort.MoveNext
Loop
Rs.MoveFirst
Do While Not Rs.EOF
Podatak = Rs.Fields(1)
If Podatak <> PodatakPrije Then
Red = Red + 1
ExcelSheet.Application.Cells(Red, 1).Value = Podatak
Podatak = Rs.Fields(2)
ExcelSheet.Application.Cells(Red, 2).Value = Podatak
Podatak = Rs.Fields(3)
ExcelSheet.Application.Cells(Red, 3).Value = Podatak
Podatak = Rs.Fields(1)
PodatakPrije = Podatak
End If
For X = 4 To Kolona Step 2
If KolS(X) = Rs!Rel Then
Podatak = Rs.Fields(5)
ExcelSheet.Application.Cells(Red, X).Value = Podatak
Podatak = Rs.Fields(6)
ExcelSheet.Application.Cells(Red, X + 1).Value = Podatak
End If
Next X
Rs.MoveNext
Loop
ExcelSheet.Application.Cells.EntireColumn.AutoFit
Red = 1
Kolona = 1
Rs.MoveFirst
Podatak = Rs.Fields(0)
ExcelSheet.Application.Cells(Red, Kolona).Value = "PREGLED NA DAN " & Podatak
ExcelSheet.Application.Visible = True
OtvoriExcel_izl:
Exit Function
OtvoriExcel_err:
MsgBox "DoĆĄlo je do greĆĄke", 48, "Greska"
Resume OtvoriExcel_izl
End Functio
Podrska 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.