Sorteren, groeperen en automatisch per groep exporteren...?

Status
Niet open voor verdere reacties.
M

Martyin

Gebruiker
Lid geworden
22 nov 2010
Berichten
18
Hoi lezers..

Ik probeer vanuit access na het filteren een export te doen vanuit bv een rapport.
Het is ff wat lastig uit te leggen maar ik hoop dat ik het duidelijk krijg.

We hebben een database waar een aantal criteria in staan waarop je filters kan leggen.
Stel , we hebben een gebied of regio, daarbinnen plaatsen, daarbinnen firma's.
Nu hebben die firma's b.v. uit 1 plaats zelf groepen opgericht. Die groepen hebben dan weer een eigen naam waar de desbetreffende firma's "onder" hangen.
Wat we nu al hebben is dat we een lijst kunnen krijgen waarop je gesorteerd en gegroepeerd de firma's met hun werknemers ziet staan die lid zijn van hun clubje.

Stapsgewijs zie je dus dit:

Regio
Plaats
Club
Leden
Club
Leden
Plaats 2
Club
Leden
Regio
Plaats
Club
Leden

Nu staat alles bv in een sheet of rapport onder elkaar.
Maar wat de bedoeling is , is dat we automatisch, per club met hun leden kunnen exporteren naar een excel sheet.
Je kan wel handmatig natuurlijk steds het filter op een van de clubs zetten en dan die uitkomst exporteren, maar het zou fijn zijn als we dat niet een 700x hoeven te doen... ;)

Makkelijker gezegd: ik heb een lijst met plaatsen waar een aantal plaatsen meerdere keren voor komen. Hoe kun je nu per plaats een dump maken zodat elke plaats een eigen excel sheet krijgt ?
Maar dan wel met 1 druk op de knop ineens alle excel bestanden genereren.
dus niet steeds met het handje een filter instellen en op export drukken..
Het ligt ongetwijfeld aan mij kennis maar ik kom er niet uit met de Macro's en vb weet ik te weinig van.

Hoe kan ik dit proces automatiseren op wat voor manier dan ook?


Graag jullie hulp
 
Laatst bewerkt:
helaas..

lijkt me een prima tool echter werkt het niet helemaal..
Ik heb te weinig kennis om dit soort dingen op te lossen.. dus als je kan helpen graag..
Ik krijg na het uitvoeren van de gevraagde stappen in het filmpje,

foutmeldingen ivm "door gebruiker gedefinieerd gegevenstype is niet gedefinieerd."

Schiet mij maar lek... :(

Wat nu?
Ik wil dit best leren, alleen weet niet waar te beginnen...
Ik zal een afbeelding proberen bij te voegen...

Picture 2.jpg

Overigens werk ik met Access versie 2007 in een XP omgeving die draait in een VmWare op een OSX omgeving. ;) ...
 
Laatst bewerkt:
Heb je wel een verwijzing naar de ADO bibliotheek? Checken in het VBA venster met <Extra>, <Verwijzingen>. Daar moet een verwijzing staan naar (liefst) ADO 2.8.
 
Dat wel..
zie att.
Picture 4.JPG

Zie net dat het 3.0 is. ? Ik ga proberen de 2.8 er bij te plaatsen.

Vandaar ook dat ik het nu niet begrijp.. Zal ongetwijfeld in de versie verschillen ergens zitten...? maar hoe verder.. Zou erg gaaf zijn als het gaat werken.

OctaFish zei:
Heb je wel een verwijzing naar de ADO bibliotheek? Checken in het VBA venster met <Extra>, <Verwijzingen>. Daar moet een verwijzing staan naar (liefst) ADO 2.8.
Klik om te vergroten...


Vreemd hoor... tis voor mij abacadabra... nu met de 2.8 start hij in elk geval op..
Verder met testen.

Ik hou jullie op de hoogte...
 
Laatst bewerkt:
Okee.. We zijn een stapje verder.

maar dan... een nieuwe uitdaging...

Nu komt er de volgende foutmelding:
 

Bijlagen

  • Picture 5.JPG
    Picture 5.JPG
    22,5 KB · Weergaven: 53
  • Picture 6.JPG
    Picture 6.JPG
    81,7 KB · Weergaven: 35
De tool werkt zelf wel. Echter exporteren naar Excel gaat dus fout met de eerder genoemde foutmelding...
Als ik de export doe binnen Access zelf werkt het wel gewoon..
Als ik dan vervolgens de gemaakte (enorme lange lijst) tabellen met het handje tegelijk wil exporteren werkt dat niet. (grayed out) maar wel per stuk. En dat is nou net wat we willen voorkomen..
We zijn er bijna zegt mijn gevoel... Maarja, dat zit er wel vaker naast... :P

Martyin zei:
Okee.. We zijn een stapje verder.

maar dan... een nieuwe uitdaging...

Nu komt er de volgende foutmelding:
Klik om te vergroten...
 
Als je de muis boven de variabele NewTableName houdt als hij vastloopt, geeft hij dan wel een waarde? Oftwel: kun je controleren of er een naam is meegegeven? Anders werkt Left uiteraard ook niet...
 
Ik begrijp wat je vraagt, het is echter nu zo dat ik er achter kwam dat het exporteren binnen 1 excel fout ging. Ik ben nu bezig met het exporteren naar losse excel bestanden zodat we alle blokken in losse bestanden krijgen.
Dit werkt voor een deel.
Na een aantal bestanden gemaakt te hebben klapt hij stuk op deze foutmelding:
Picture 7.JPG

Ik denk dat het te maken heeft met een "naamgeving" in het veld.
Daar zoek ik even naar...




OctaFish zei:
Als je de muis boven de variabele NewTableName houdt als hij vastloopt, geeft hij dan wel een waarde? Oftwel: kun je controleren of er een naam is meegegeven? Anders werkt Left uiteraard ook niet...
Klik om te vergroten...
 
Ok, SUPERRRRRRRRRRRRRRRRR Het loopt.

Zat hem in de bestandsnaamgeving. Als er een naam is met een breukstreep in de
kolom die je wilt gebruiken dan knalt hij daarop omdat windows geen breukstrepen in de naam accepteert. (Werk hier op een Mac en die kan dat wel.)

Nu moet ik alleen nog het automatisch formateren voor elkaar zien te krijgen.

zaakjes als:
- titelbalk text verticaal zetten
- de meest linker colom de naam van het 1e veld uitlezen en in een cel rechts erboven van die 1e colom plaatsen
- De breedtes aanpassen

hehehe..

Maar echt super dat we al zover zijn.!!!

Bijna klaar!

Martyin zei:
De tool werkt zelf wel. Echter exporteren naar Excel gaat dus fout met de eerder genoemde foutmelding...
Als ik de export doe binnen Access zelf werkt het wel gewoon..
Als ik dan vervolgens de gemaakte (enorme lange lijst) tabellen met het handje tegelijk wil exporteren werkt dat niet. (grayed out) maar wel per stuk. En dat is nou net wat we willen voorkomen..
We zijn er bijna zegt mijn gevoel... Maarja, dat zit er wel vaker naast... :P
Klik om te vergroten...
 
Ok, het werkt nu redelijk, behalve het formateren.
Daar kom ik nog niet uit.
Kan iemand enigzins helpen hoe dit aan te pakken?

Ik kan de code openen en vervolgens naar de juiste sectie gaan waar staat ' do some formatting
Vanaf daar snap ik wel wat er staat maar weet niet hoe ik nieuwe dingen moet doen.
Als iemand zou kunnen helpen stel ik dat zeer op prijs.

Alvast mijn dank hiervoor..

Martin
 
Laatst bewerkt:
Volgende doet zich voor...
Ik kan bij het exporteren van de gegevens de format aanpassen... !!!
Echter alleen als ik dit doe in de optie waarbij er 1 excel sheet gemaakt wordt waarbij
de format er overheen gaat.

Als ik dit probeer in de optie waarbij steeds een nieuw excel book wordt aangemaakt klapt hij. Kan het niet ????

Zal wel iets met die "loop" te maken hebben.
Hij gooit de format er alleen bij het eerste sheet over in het 1e excel docje, bij het tweede klapt hij.

Wil iemand me helpen? De hele dag al bezig... pfff.
 
Deze foutmelding krijg ik constant...
:confused:

Picture 8.JPG

Dit is de code:
'Vanaf hier ingevoegde Macro code
'Tekst verticaal zetten in de eerste row
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Het werkt dus bij de keuze waar hij de format uitvoert als hij meerdere losse excel sheets aan moet gaan maken..
De zelfde code werkt wel als het binnen 1 workbook met meerdere tab bladen wordt gedaan.

Iemand ? :confused:
 
Laatst bewerkt:
@Martyin,

Helaas hebben wij geen inzage van de inhoud van jouw bestand. Dan wordt het natuurlijk wel een beetje gissen wat er fout gaat.

In het instructiefilmpje worden er een aantal beperkingen aangegeven. Allereerst een opsomming van tekens die niet gebruikt mogen worden. Vervolgens is er ook een beperking op het aantal kolommen en rijen. Heb je daar al goed naar gekeken.

De verwijzing naar de Excel bibliotheek heb je al gemaakt. Maar de verwijzing naar "Microsoft ActiveX Data Object 2.1 Libary" (ook al genoemd door Michel) heb ik niet gezien. Dus kijk even of die ook geselecteerd is hebt bij de verwijzingen.
 
Goedemorgen Charles,

Ik kanhet hele bestand wel bijvoegen..
Geen punt..
Je kan het hier afhalen, onderaan de pagina..
http://www.datapigtechnologies.com/AccessMain.htm

Waar het op stuk loopt is de loop/opslaan losse werkbladen.

Simpel gezegd, ik heb geen verstand van code. Dus wat doe je dan? Dan ga je leren.
Wel ik bedacht me als ik nou de Macro opname laat lopen in een excel sheet wat ik graag in een bepaalde vorm wil hebben dan genereerd Excel de code wel.
Die code plak je dan op de plaats waar het formatten begint in de code van de exploder in Access.

Dat werkt!

Echter alleen op de plek waar je gekozen hebt voor de optie van alles in 1 excel book en de data in tab bladen zetten.


De code is dus gewoon die zelfde van de makers zoals eerder genoemd.
Het enige wat ik wil is dat er hulp komt , of iemand die het even voor mij kan aanpassen en de voorzet kan geven,
om op de boven beschreven methode zelf de formatting te kunnen doen.

Je kan het dus heel makkelijk even zelf doen als je dat wilt.
Om zeker te zijn van "schone" versie kun je het beste even die van de site afhalen

Het eerste stuk slaat op losse werkbladen en het tweede stuk slaat op de losse sheets.

Onder het stukje " 'do some formatting "
Daar zit ik te pielen.

Snap je mij? Ik heb moeite met code omdat ik gewoonweg niet weet wat ik moet typen.
Ik weet dat het kan maar weet niet hoe...

Dankje!

Bakk4318 zei:
@Martyin,

Helaas hebben wij geen inzage van de inhoud van jouw bestand. Dan wordt het natuurlijk wel een beetje gissen wat er fout gaat.

In het instructiefilmpje worden er een aantal beperkingen aangegeven. Allereerst een opsomming van tekens die niet gebruikt mogen worden. Vervolgens is er ook een beperking op het aantal kolommen en rijen. Heb je daar al goed naar gekeken. De verwijzing naar de Excel bibliotheek heb je al gemaakt. Maar de verwijzing naar "Microsoft ActiveX Data Object 2.1 Libary" (ook al genoemd door Michel) heb ik niet gezien.
Klik om te vergroten...
 
Laatst bewerkt:
Charles bedoelt dat we geen inzage hebben in jouw bestand... En daar zit het probleem, niet in het voorbeeld van Datapig. Dus misschien kun je een voorbeeldje maken waar het bij jou fout gaat?
 
Ok, hier is de code.
Wat ik ontcijferd heb, daar heb ik gepoogd aanpassingen te doen.

De blokken die ik herkende heb ik met NL tekst beschreven.
Als het niet klopt hoor ik het graag van jullie..


Code: 
Option Compare Database
Option Explicit
'**************************************************
'  ||||DATAPIG ACCESS EXPLOSION||||
'  Developed by Mike Alexander
'  December 2004
'  [url]www.DatapigTechnologies.com[/url]
'
'  You are free to use this form in any application
'  provided the copyright notice is left unchanged.
'**************************************************

'API for browser function
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Sub btngetdirectory_Click()
Call GETDIR
End Sub

Private Sub btnrefreshcollist_Click()
Call GetColumns
End Sub

Private Sub btnrefreshtbllist_Click()
Call GetTables
End Sub

Private Sub btnrunoutput_Click()
'check for empty comboboxes
If Me.cboTablesList.Value = "" Or IsNull(Me.cboTablesList.Value) Then
MsgBox "You must select a Table", , "DataPig Access Explosion"
ElseIf Me.cbocolumnlist.Value = "" Or IsNull(Me.cbocolumnlist.Value) Then
MsgBox "You must select a Column", , "DataPig Access Explosion"

Else

DoCmd.Hourglass True

Call OutPutProcesses

DoCmd.Hourglass False
Me.txtcurrent.Value = ""

End If
End Sub

Private Sub cboTablesList_AfterUpdate()
Call GetColumns
End Sub


Private Sub Form_Open(Cancel As Integer)
Me.cbocolumnlist.RowSource = ""
Me.cboTablesList.RowSource = ""
Call GetTables
DoCmd.Restore

End Sub

Private Function GetTables()

Dim Myarray As Variant
Dim TablesSchema As ADODB.Recordset
Dim conn As ADODB.Connection

'reset cursorlocation to allow sorting in ordinal_position
   Set conn = CurrentProject.Connection
   With conn
   .CursorLocation = adUseClient
   End With
   
'Get all database tables.
 Set TablesSchema = conn.OpenSchema(adSchemaTables)
 TablesSchema.Sort = ("TABLE_NAME")
 
 Me.cboTablesList.RowSource() = ""
 Do While Not TablesSchema.EOF
 
 'Exclude System Tables and Default Treeview Table
 If Left(TablesSchema("TABLE_NAME"), 4) = "MSYS" Or TablesSchema("TABLE_NAME") = "TREEVIEWFEED" Or Left(TablesSchema("TABLE_NAME"), 1) = "~" Then
 GoTo SKIP
 End If
 
        'Add Tables to the Combobox
        Myarray = Me.cboTablesList.RowSource()
        If Me.cboTablesList.ListCount < 1 Then
        Me.cboTablesList.RowSource = TablesSchema("TABLE_NAME")
        Else
        Me.cboTablesList.RowSource = Myarray & ";" & TablesSchema("TABLE_NAME")
        End If
SKIP:
 TablesSchema.MoveNext
 Loop


Set TablesSchema = Nothing
End Function

Private Function GetColumns()

Dim Myarray As Variant
Dim ColumnsSchema As ADODB.Recordset
Dim conn As ADODB.Connection

'reset cursorlocation to allow sorting in ordinal_position
   Set conn = CurrentProject.Connection
   With conn
   .CursorLocation = adUseClient
   End With

'Get all Columns in the table selected in table selection combobox
   Set ColumnsSchema = conn.OpenSchema(adSchemaColumns, Array(Empty, Empty, "" & Me.cboTablesList))
   ColumnsSchema.Sort = "ORDINAL_POSITION"
        
 'clear columns combobox
 Me.cbocolumnlist.RowSource = ""
 
 'Add columns to the Combobox
 Do While Not ColumnsSchema.EOF
 On Error GoTo SKIP
       
        Myarray = Me.cbocolumnlist.RowSource()
        If Me.cbocolumnlist.ListCount < 1 Then
        Me.cbocolumnlist.RowSource = ColumnsSchema("COLUMN_NAME")
        Else
        Me.cbocolumnlist.RowSource = Myarray & ";" & ColumnsSchema("COLUMN_NAME")
        End If
        
SKIP:
 ColumnsSchema.MoveNext
 Loop

Set ColumnsSchema = Nothing

End Function

Private Function OutPutProcesses()
Dim MyLoopingSET As ADODB.Recordset
Dim MyExcelSet As ADODB.Recordset
Dim Mysql As String
Dim MYsql2 As String
Dim MyTable As String
Dim MyCriteria As String
Dim MyTableColumnString As String
Dim Mydirectory As String
Dim NewTableName As String
Dim xl As Excel.Application
Dim xlwkbk As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim xlrange As Excel.Range
Dim blankvariant As Variant
Dim dynamicarray() As Variant
Dim intcolumns As Integer
Dim introws As Integer
Dim X As Long
Dim Y As Long
Dim intmaxcol As Integer
Dim intmaxrow As Integer
Dim i As Long
Dim c As Long

'CREATE STRINGS FOR EASY USE IN SQL STATEMENTS
MyTable = "[" & Me.cboTablesList & "]"
MyTableColumnString = "[" & Me.cboTablesList & "]" & "." & "[" & Me.cbocolumnlist & "]"

'CREATE LOOPING RECORDSET
    Set MyLoopingSET = New ADODB.Recordset
    Mysql = "SELECT NZ(" & MyTableColumnString & ",0)AS LoopColumn FROM" & MyTable & "GROUP BY" & MyTableColumnString & "ORDER BY" & MyTableColumnString & ";"
    MyLoopingSET.Open Mysql, CurrentProject.Connection, adOpenStatic
    
'CHECK FOR 0 RECORDS
    MyLoopingSET.MoveLast:  MyLoopingSET.MoveFirst
    If MyLoopingSET.RecordCount < 1 Then
    MsgBox "No Records Found", , "DataPig Access Explosion"
    Set MyLoopingSET = Nothing
    Exit Function
    End If
    
'CHECK OUTPUT VALUE SELECTION
Select Case Me.OptionOutput.Value

    'USER CHOSE TO MAKE ACCESS TABLES
Case Is = 1
            Do Until MyLoopingSET.EOF
            On Error GoTo SKIP1
            
            'Check for entries that would be an invalid table name
            If MyLoopingSET!LOOPCOLUMN Like "*.*" Then
            GoTo SKIP1
            ElseIf MyLoopingSET!LOOPCOLUMN Like "*!*" Then
            GoTo SKIP1
            ElseIf MyLoopingSET!LOOPCOLUMN Like "*`*" Then
            GoTo SKIP1
            ElseIf MyLoopingSET!LOOPCOLUMN Like " *" Then
            GoTo SKIP1
            End If
            
            'let user know which record we're on
            Me.txtcurrent.Value = "Outputting " & MyLoopingSET!LOOPCOLUMN
            DoEvents
            
            'RUN MAKE TABLE FOR EACH VALUE IN LOOPING LIST
            NewTableName = Left(Me.cboTablesList & "-" & MyLoopingSET!LOOPCOLUMN, 64)
            MYsql2 = "SELECT * INTO " & "[" & NewTableName & "]" & " FROM " & MyTable & " WHERE " & MyTableColumnString & "=" & "'" & MyLoopingSET!LOOPCOLUMN & "'" & ";"
            DoCmd.SetWarnings False
            DoCmd.RunSQL MYsql2
            DoCmd.SetWarnings True
SKIP1:
            
            MyLoopingSET.MoveNext
            Loop
'*******************************************************************************
'*******************************************************************************
'*******************************************************************************
'USER CHOSE TO MAKE SEPARATE EXCEL WORKBOOKS
'*******************************************************************************
'*******************************************************************************
'*******************************************************************************
 
 Case Is = 2
            
            'check for empty output directory
            If Me.txtoutputdirectory = "" Or IsNull(Me.txtoutputdirectory.Value) Then
            MsgBox "You must specify an output directory", , "DataPig Access Explosion"
            Me.txtoutputdirectory.SetFocus
            Exit Function
            End If
             
             Do Until MyLoopingSET.EOF
             On Error GoTo SKIP2
             'let user know which record we're on
             Me.txtcurrent.Value = "Outputting " & MyLoopingSET!LOOPCOLUMN
             DoEvents
            
            'Set SQL statement that we will output
            NewTableName = Me.cboTablesList & "-" & MyLoopingSET!LOOPCOLUMN
            MYsql2 = "SELECT *" & " FROM " & MyTable & " WHERE " & MyTableColumnString & "=" & "'" & MyLoopingSET!LOOPCOLUMN & "'" & ";"
            
            'Open excel and add an new Workbook and worksheet
            Set MyExcelSet = New ADODB.Recordset
            Set xl = New Excel.Application
            Set xlwkbk = xl.Workbooks.Add
            Set xlsheet = xlwkbk.Worksheets.Add
            Mydirectory = Me.txtoutputdirectory
            
            'open our recordset and count records
            MyExcelSet.Open MYsql2, CurrentProject.Connection, adOpenStatic
 
            If MyExcelSet.RecordCount < 1 Then
            GoTo SKIP2
            End If
            
            intmaxcol = MyExcelSet.Fields.Count
            MyExcelSet.MoveLast:  MyExcelSet.MoveFirst
            intmaxrow = MyExcelSet.RecordCount
            '*******************************************************************************
            '*******************************************************************************
            'transfer data to excel !!
            '*******************************************************************************
            '*******************************************************************************
            'This piece of code replaces the .copyfromrecordset method in Excel
            'this way provides more flexibility and its alot faster than copyfromrecordset
            'Developed by Robert Zey
                            
                            Set xlrange = xlsheet.Range("A2")
                            blankvariant = MyExcelSet.GetRows(intmaxrow)
                            intcolumns = UBound(blankvariant, 1)
                            introws = UBound(blankvariant, 2)
                            
                            ReDim dynamicarray(introws, intcolumns)
                            For X = 0 To introws
                            For Y = 0 To intcolumns
                            
                            dynamicarray(X, Y) = blankvariant(Y, X)
                            Next Y
                            Next X
                            
                            xlrange.Resize(introws + 1, intcolumns + 1).Value = dynamicarray
             '*******************************************************************************
             '*******************************************************************************
             '*******************************************************************************
                 xl.DisplayAlerts = True
                'Name current sheet
                xl.ActiveSheet.Name = Left(NewTableName, 30)
            
                'use cbocolumnlist to fill in headers
                c = 1
                For i = 0 To Me.cbocolumnlist.ListCount
                xl.ActiveSheet.Cells(1, c).Value = Me.cbocolumnlist.ItemData(i)
                c = c + 1
                Next i
            '*******************
            '*******************
            'do some formatting
            '*******************
            '*******************
                
                xl.Cells.Select
                With xl.Selection.Font
                    .Name = "Courier"
                    .Size = 8
                   ' .HorizontalAlignment = xlGeneral
                   ' .WrapText = False
                 
                End With
                'xl.Range("A1").AutoFilter
                'xl.Cells.Select
                xl.Cells.EntireColumn.AutoFit
                xl.Rows("1:1").Select
                xl.Selection.Font.ColorIndex = 9
                With xl.Selection.Interior
                    .ColorIndex = 15
                    .Pattern = xlSolid
                End With
                                            
                
            'Vanaf hier ingevoegde Macro code
            'Tekst verticaal zetten in de eerste row
                'xl.Rows("1:1").Select
                '    With Selection
                '   .HorizontalAlignment = xlGeneral
                '    .VerticalAlignment = xlBottom
                '    .WrapText = False
                '    .Orientation = 90
                '    .AddIndent = False
                '    .IndentLevel = 0
                '    .ShrinkToFit = False
                '    .ReadingOrder = xlContext
                '    .MergeCells = False
                'End With
                    
              
            '*******************
            '*******************
            'save file
            '*******************
            '*******************
                
                
                xl.ActiveWorkbook.SaveAs Filename:=Mydirectory & "\" & NewTableName & ".xls", _
                FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False






'*******************************************************************************
'*******************************************************************************
'*******************************************************************************
'USER CHOSE TO MAKE SEPARATE EXCEL SHEETS!!!
'*******************************************************************************
'*******************************************************************************
'*******************************************************************************

SKIP2:
                'Clean up
                    xl.ActiveWorkbook.Close
                    xl.Quit
                    Set xl = Nothing
                    Set xlwkbk = Nothing
                    Set xlsheet = Nothing
                    Set xlrange = Nothing
                    Set MyExcelSet = Nothing

MyLoopingSET.MoveNext
Loop
        
               
Case Is = 3
                                       
            'check for empty output directory
            If Me.txtoutputdirectory = "" Or IsNull(Me.txtoutputdirectory.Value) Then
            MsgBox "You must specify an output directory", , "DataPig Access Explosion"
            Me.txtoutputdirectory.SetFocus
            Exit Function
            End If
            
             'Open Excel and add a Workbook
             Set xl = New Excel.Application
             Set xlwkbk = xl.Workbooks.Add
             
             Do Until MyLoopingSET.EOF
             On Error GoTo SKIP3
          
             'let user know which record we're on
             Me.txtcurrent.Value = "Outputting " & MyLoopingSET!LOOPCOLUMN
             DoEvents
            
            'Set SQL statement that we will output
            NewTableName = Me.cboTablesList & "-" & MyLoopingSET!LOOPCOLUMN
            MYsql2 = "SELECT *" & " FROM " & MyTable & " WHERE " & MyTableColumnString & "=" & "'" & MyLoopingSET!LOOPCOLUMN & "'" & ";"
            
            'Add an new Workbook and worksheet
            Set MyExcelSet = New ADODB.Recordset
            Set xlsheet = xlwkbk.Worksheets.Add
            Mydirectory = Me.txtoutputdirectory
            
            'open our recordset and count records
            MyExcelSet.Open MYsql2, CurrentProject.Connection, adOpenStatic
            
            If MyExcelSet.RecordCount < 1 Then
            GoTo SKIP3
            End If
            
            intmaxcol = MyExcelSet.Fields.Count
            MyExcelSet.MoveLast:  MyExcelSet.MoveFirst
            intmaxrow = MyExcelSet.RecordCount
    '*******************************************************************************
    '*******************************************************************************
    'transfer data to excel Bij de keuze alles binnen een workbook... !!!
    '*******************************************************************************
    '*******************************************************************************
            'This piece of code replaces the .copyfromrecordset method in Excel
            'this way provides more flexibility and its alot faster than copyfromrecordset
            'Developed by Robert Zey
                         
                            Set xlrange = xlsheet.Range("A2")
                            blankvariant = MyExcelSet.GetRows(intmaxrow)
                            intcolumns = UBound(blankvariant, 1)
                            introws = UBound(blankvariant, 2)
                            
                            ReDim dynamicarray(introws, intcolumns)
                            For X = 0 To introws
                            For Y = 0 To intcolumns
                            
                            dynamicarray(X, Y) = blankvariant(Y, X)
                            Next Y
                            Next X
                            
                            xlrange.Resize(introws + 1, intcolumns + 1).Value = dynamicarray
             '*******************************************************************************
               xl.DisplayAlerts = False
                'Name current sheet
                xl.ActiveSheet.Name = Left(NewTableName, 30)
            
                'use cbocolumnlist to fill in headers
                c = 1
                For i = 0 To Me.cbocolumnlist.ListCount
                xl.ActiveSheet.Cells(1, c).Value = Me.cbocolumnlist.ItemData(i)
                c = c + 1
                Next i
        'Vanaf hier de code gemaakt met de Macro's
        'Tekst verticaal zetten in de eerste row
                Rows("1:1").Select
                    With Selection
                    .HorizontalAlignment = xlGeneral
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 90
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
    'Copieeeeeeer de data uit het eerste veld en plaats die in de cel boven plaats
                Rows("1:1").Select
                    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Range("A3").Select
                    Selection.Copy
                    Range("C1").Select
                    ActiveSheet.Paste
    'Eerste colom weggooien en lijntjes boven tekenen.
                Columns("A:A").Select
                Selection.Delete Shift:=xlToLeft
                Range("A2:AB2").Select
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
        With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("M12").Select
    ActiveWindow.SmallScroll Down:=-6
    End With
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("J3:AC16").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("AD2").Select
    Columns("AC:AC").ColumnWidth = 30.43
    Range("AC2").Select
    Selection.Style = "Normal"
            Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C2").Select
    Selection.Cut
    Range("D2").Select
    ActiveSheet.Paste
    Range("C2").Select
    Selection.ClearContents
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "FTO Naam"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "YAZ"
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "Qlaira"
    Range("X2").Select
    ActiveCell.FormulaR1C1 = "Follow Up"
    Range("X3").Select
    Range("D2:G2").Select
    Selection.Merge
    Range("J2:P2").Select
    Selection.Merge
    Range("Q2:W2").Select
    Selection.Merge
    Range("X2:AB2").Select
    Selection.Merge
    Range("AC3").Select
        Range("D2:I2").Select
    Selection.Merge
    Range("J2:P2").Select
    Selection.Merge
    Range("Q2:W2").Select
    Selection.Merge
    Range("X2:AB2").Select
    Selection.Merge
    Range("AC3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("C2:AB2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("B3:AC3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("J2:P3").Select
    Range("P3").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("Q2:W3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("X2:AB3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("P3").Select
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Range("W3").Select
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Range("J3:AB3").Select
    Selection.Font.Bold = True
    Range("B3:I3").Select
    Selection.Font.Bold = True
    Range("C2:AB2").Select
    Selection.Font.Bold = True
    
        
        
               'do some formatting
               ' xl.Cells.Select
               ' With xl.Selection.Font
               '      .Name = "Arial"
               '     .Size = 8
               ' End With
               ' xl.Range("A1").AutoFilter
               ' xl.Cells.Select
               ' xl.Cells.EntireColumn.AutoFit
               ' xl.Rows("1:1").Select
               ' xl.Selection.Font.ColorIndex = 9
               ' With xl.Selection.Interior
               '     .ColorIndex = 15
               '     .Pattern = xlSolid
               ' End With
               ' xl.Range("A1").Select
                
SKIP3:
MyLoopingSET.MoveNext
Loop
                
                'save file
                  xl.ActiveWorkbook.SaveAs Filename:=Mydirectory & "\" & Me.cboTablesList & ".xls", _
                FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
 
                'Clean up
                    xl.ActiveWorkbook.Close
                    xl.Quit
                    Set xl = Nothing
                    Set xlwkbk = Nothing
                    Set xlsheet = Nothing
                    Set xlrange = Nothing
                    Set MyExcelSet = Nothing
      
End Select
    
    Set MyLoopingSET = Nothing
    MsgBox "Output Completed!", , "DataPig Access Explosion"
    
    End Function


Private Function GETDIR()
  Dim mybrowse As BROWSEINFO
  Dim Mydirectory As String
  
    Dim path As String
    Dim R As Long, X As Long, pos As Integer
    
    mybrowse.pidlRoot = 0&

'************************************************************************************************
'0 'Desktop is the root directory. With BIF_returnonlyfsdirs circumvents problem with OK-button *
'1 'Internet Explorer is the root                                                               *
'2 'Programs folder of the start menu is the root                                               *
'3 'Control Panel is the root. Needs BIF_browseincludefiles                                     *
'4 'Printers folder is the root. Needs BIF_browseincludefiles                                   *
'5 'Documentsfolder is the root                                                                 *
'6 'Favorites is the root                                                                       *
'7 'Startup-folder of the startmenu is the root. Needs BIF_browseincludefiles                   *
'8  'Recentfolder is the root. Needs BIF_browseincludefiles                                     *
'9 'Sendto-folder is the root. Needs BIF_browseincludefiles                                     *
'10 'Recycle Bin is the root. Needs BIF_browseincludefiles                                      *
'11 'Start Menu is the root                                                                     *
'16 'The Desktopdirectory is the root directory                                                 *
'17 'The drives (My computer) folder is the root                                                *
'18 'The networkneighbourhood is the root                                                       *
'19 'The nethoodfolder is the root                                                              *
'20 'The fontsfolder is the root                                                                *
'21 'The templatesfolder is the root                                                            *
'************************************************************************************************
  
        mybrowse.lpszTitle = "SELECT A DIRECTORY"
   
    mybrowse.ulFlags = &H1 '(H4000 RETURNS FILENAME)

    X = SHBrowseForFolder(mybrowse)
    
    path = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal path)
    If R Then
        pos = InStr(path, Chr$(0))
        Mydirectory = Left(path, pos - 1)
        
        Me.txtoutputdirectory.Value = Mydirectory
        
            
End If
End Function
 
Laatst bewerkt:
Zou je ons een plezier kunnen doen en de code hierboven in de CODE tag opmaken? Dit is wel een heeeeeeeeeeeeeeeel lange tekst....
 
Oeps

Ehh.. hoe moet dat? Sorry...
OctaFish zei:
Zou je ons een plezier kunnen doen en de code hierboven in de CODE tag opmaken? Dit is wel een heeeeeeeeeeeeeeeel lange tekst....
Klik om te vergroten...


Kijk, gevonden...
;)
Ik leer steeds bij... Leuk !
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan