How to export filtered table to Ms.Excel 2007

[hendy13]

Good day developers. I want to ask about how to export filtered table to Ms.Excel 2007. so this vba code to filtered the table :

Dim db As Database
    Dim rst As DAO.Recordset
    Dim strSQL As String
    Dim flnm As String
    Dim appXl As Excel.Application
    Dim bookXl As Excel.Workbook
    Const wrksheetName As String = "Welder Performance Overall"
    
    On Error Resume Next
    
    Set db = CurrentDb()
    strSQL = "SELECT * FROM weld_performance WHERE welder_ident = '" & Me.Combo26.Value & "'"
    Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot, dbSeeChanges)
    
    flnm = "G:\PROJECT\8382 - BCJV\017 - Quality Control Records\017.20 - Quality Control Records\017.20.25 Welders Weekly Performance Record\Welder Records - Piping\Welder Performance Overall\Excel Format\" & Me.Combo26.Value & " " & Format(Now(), "dd-MMM-yyyy")
Set appXl = CreateObject("Excel.Application")
    appXl.Visible = False
    Set bookXl = appXl.Workbooks.Open(flnm)
    DoCmd.OutputTo acOutputTable, "weld_performance", acFormatXLS, flnm & "Welder Performance Overall " & Format(Now(), "dd-MMM-yyyy") & ".xls", True
    'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "", flnm, True

    bookXl.Close
    appXl.Quit
    rst.Close
    Set db = Nothing
    Set rst = Nothing
    Set appXl = Nothing

if i use DoCmd.OutputTo function, its export the whole table to excel. how can i filter this table ? thanks. Environment : Ms.Access 2010

 

[mh123]

Hi

Here's code I have for exporting a filtered qry

Dim rst As DAO.Recordset
    Dim customQuery As String
    Dim cnt As Integer
    Dim ID As String
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
        
    ID = yourfilter
    
    customQuery = "Select * from QRY WHERE ID = " & ID & ""
    Set appExcel = Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Add
    Set wks = wbk.Worksheets(1)
    Set rng = wks.Range("A2:I4001")
    wks.Cells(1, 1).Value = "Generating data..."
    
    Set rst = CurrentDb.OpenRecordset(customQuery)
    If (rst.RecordCount > 0) Then
        cnt = 1
        For Each fld In rst.Fields
            wks.Cells(1, cnt).Value = fld.Name
            cnt = cnt + 1
        Next fld
        Call rng.CopyFromRecordset(rst, 4000, 26)
    End If
    
    rst.Close
    Set rst = Nothing

I didn't write this initial code I just changed the parts relevant to my needs and I hope you can do the same, just add your extra lines at the end if required to save the sheet somewhere and set visible to false etc

HTH

 

[hendy13]

@mh123, So i add 1 combobox and the data is MCD-1100,MCD-1101,... and then i add a button. onClick code of the button i put :

    Dim rst As DAO.Recordset
    Dim customQuery As String
    Dim cnt As Integer
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    
    customQuery = "Select * from Query4 WHERE welder_ident = " & Me.Combo248.Value & ""
    Set appExcel = Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Add
    Set wks = wbk.Worksheets(1)
    Set rng = wks.Range("A2:I4001")
    wks.Cells(1, 1).Value = "Generating data..."
    
    Set rst = CurrentDb.OpenRecordset(customQuery)
    If (rst.RecordCount > 0) Then
        cnt = 1
        For Each fld In rst.Fields
            wks.Cells(1, cnt).Value = fld.Name
            cnt = cnt + 1
        Next fld
        Call rng.CopyFromRecordset(rst, 4000, 26)
    End If
    
    rst.Close
    Set rst = Nothing

what i want to ask is:

1. what should i add in this line

   ID = yourfilter

   ? because i want to filter based on the combobox. please see my code above.
2. what is the code to save the current filttered excel ?

Thanks for your reply.

 

[mh123]

so how i'd do it (preference more than anything I think)
Dim Welder as String
Welder = Me.Combo26.Value

then your customQuery "SELECT * FROM weld_performance WHERE welder_ident = " % Welder % ""

But if it's pulling through the right data as it is then no worries I guess.
To save as,
Dim fileName as string
filename = "C:\folder\folder\folder\bla.xls" (you can put in anything into the filename using strings as you would elsewhere)
then
wks.SaveAs (filename)

If you are saving to a network drive that isn't C you will need to use the direct file path to that drive, to get that open a cmd prompt and type 'net use' hit enter and it should show you the direct paths to drives that you can then use to save on folders there.

This should be enough to get you on the right track, HTH and let me know how you get on.

 

[hendy13]

@mh123, i already modified my code, but still error.

    Dim rst As DAO.Recordset
    Dim customQuery As String
    Dim cnt As Integer
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim welder As String
    Dim flname As String
    
    welder = Me.Combo26.Value
    flname = "G:\PROJECT\8382 - BCJV\017 - Quality Control Records\017.20 - Quality Control Records\017.20.25 Welders Weekly Performance Record\Welder Records - Piping\Welder Performance Overall\Excel Format\Welder Performance Overall 03-Apr-2014.xls"
    
    customQuery = "Select * from weld_performance WHERE welder_ident = " & welder
    Set appExcel = Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Add
    Set wks = wbk.Worksheets(1)
    Set rng = wks.Range("A2:I4001")
    wks.Cells(1, 1).Value = "Generating data..."
    
    Set rst = CurrentDb.OpenRecordset(customQuery)   <<<< Error in this line
    If (rst.RecordCount > 0) Then
        cnt = 1
        For Each fld In rst.Fields
            wks.Cells(1, cnt).Value = fld.Name
            cnt = cnt + 1
        Next fld
        Call rng.CopyFromRecordset(rst, 4000, 26)
    End If
    
    wks.SaveAs (flname)
    
    rst.Close
    Set rst = Nothing

the error say:

Run-time error '3061':

Too few parameters. Expected 1

the excel file is open, and the data is just "Generating Data..."

please i need some guide. thanks for your help

 

[mh123]

The parameter hasn't been defined

Here you need to close off with a & ""
customQuery = "Select * from weld_performance WHERE welder_ident = " & welder
needs to be customQuery = "Select * from weld_performance WHERE welder_ident = " & welder & ""
Let me know how you get on

 

[hendy13]

Is there anyone who can help me please :banghead:

 

[hendy13]

@mh123 using your code, finally i can solve my problem. thanks a lot ms123, you are great

here is my code :

Private Sub Command250_Click()
    Dim rst As DAO.Recordset
    Dim customQuery As String
    Dim cnt As Integer
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim welder As String
    Dim flname As String
    
    'welder = Me.Combo26.Value
    flname = "G:\PROJECT\8382 - BCJV\017 - Quality Control Records\017.20 - Quality Control Records\017.20.25 Welders Weekly Performance Record\Welder Records - Piping\Welder Performance Overall\Excel Format\Welder Performance Overall 03-Apr-2014.xls"
    
    customQuery = "Select * from weld_performance WHERE welder_ident = '" & Me.Combo26.Value & "'"
    Set appExcel = Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Add
    Set wks = wbk.Worksheets(1)
    Set rng = wks.Range("A2:I4001")
    wks.Cells(1, 1).Value = "Generating data..."
    
    Set rst = CurrentDb.OpenRecordset(customQuery)
    If (rst.RecordCount > 0) Then
        cnt = 1
        For Each fld In rst.Fields
            wks.Cells(1, cnt).Value = fld.Name
            cnt = cnt + 1
        Next fld
        Call rng.CopyFromRecordset(rst, 4000, 26)
    End If
    
    'wks.SaveAs (flname)
    
    rst.Close
    Set rst = Nothing
End Sub

 

[hendy13]

@mh123, can i ask you again ?? what i want to ask is :

1. how can i make all font to became Arial in vba code inside your codes?
2. how can i make all text align center, and middle align in vba code inside your codes?
3. how can i make all borders (black colors) from A1 cell to H2 cell ?
4. how can i make all text to auto fit ?
5. and, how can i make a row from A1 until H1 color cell is White, background 1, darker 25% ?

because a picture worth thousand words, this is the image result from your code, please see attach result.jpeg:





and this is what i want to achive in excel format using your codes:





thanks for your help mh123

 

[mh123]

Hi

What you can do is go into excel and record a macro then save it and you'll have the code you need to set the formatting to what you want, for instance;

Set wks = wbk.Worksheets(1)
         With wks.Rows("1:1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
        End With
        With wks.Rows("1:1").Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
        .Bold = True
End With

This is just something I already have which you can see sets Row 1:1 (all the column names in the first row) but you can then adapt it to what you need (based on what your macro comes up with after you record it in excel) and set the formatting you want on more specific ranges or cells.

HTH and makes sense, let me know how you get on!

 

[hendy13]

@mh123, i already used your code and solve my second problem. so this is the result picture:



as you can see, i already export the filtered table to excel, then set the property such as borders, font, alignment, background color, etc. now based on this data in excel, i want to create a chart, the type is xlColumnClustered. until this step, i already done. but now my problem is, the series is just showing 1 data. what i want to ask with you is, how can i show another 6 series inside that chart, such as :

• weld_prod ??
• weld_rt_acc ??
• weld_rej_r1 ?
• weld_rej_r2 ?
• weld_total_r ?
• weld_total_rt ?
• weld_rej_rate ?

thanks you for your reply mh123.

this is the code :

    Const xlContinuous = 1
    Const xlThick = 4
    Dim rst As DAO.Recordset
    Dim customQuery As String
    Dim cnt As Integer
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim rPatterns As Range
    Dim iSeries As Long
    Dim rSeries As Range
    Dim welder As String
    Dim flname As String
    Dim chartObuject As ChartObject

customQuery = "Select * from weld_performance WHERE welder_ident = '" & Me.Combo258.Value & "'"
    Set appExcel = Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Add
    Set wks = wbk.Worksheets(1)
    Set rng = wks.Range("A5:H5")
    rng.Select
    rng.HorizontalAlignment = xlCenter
    rng.Borders.LineStyle = xlContinuous
    rng.Borders.Color = RGB(0, 0, 0)
    rng.Borders.Weight = xlThin
    rng.WrapText = False
    rng.Font.size = 10
    rng.Font.Name = "Arial"
    rng.HorizontalAlignment = xlCenter
    rng.VerticalAlignment = xlCenter
    wks.Cells(4, 1).Value = "Generating data..."
    wks.Cells(1, 1).Value = "WELDERS PERFORMANCE PER JOINT - PER WELDER"
    
    With Range("A1:H2")
        .MergeCells = True
        .Font.size = 18
        .Font.Bold = True
        .Font.Underline = True
        .Font.Name = "Arial"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
    Set rst = CurrentDb.OpenRecordset(customQuery)
    If (rst.RecordCount > 0) Then
        cnt = 1
        For Each fld In rst.Fields
            wks.Cells(4, cnt).Value = fld.Name
            cnt = cnt + 1
        Next fld
        Call rng.CopyFromRecordset(rst, 4000, 26)
    End If
    
    With Range("A4:H4")
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(0, 0, 0)
        .Borders.Weight = xlThin
        .EntireColumn.AutoFit
        .Interior.Color = RGB(191, 191, 191)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Name = "Arial"
        .Font.Bold = True
        .Font.size = 10
    End With
    
    With wks.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4
        .Zoom = 100
        .LeftMargin = .Application.InchesToPoints(0.25)
        .RightMargin = .Application.InchesToPoints(0.25)
        .TopMargin = .Application.InchesToPoints(0.5)
        .BottomMargin = .Application.InchesToPoints(0.5)
        .HeaderMargin = .Application.InchesToPoints(0.5)
        .FooterMargin = .Application.InchesToPoints(0.5)
        .FirstPageNumber = xlAutomatic
    End With
    
    Set chartObuject = ActiveSheet.ChartObjects.Add(Left:=75, Width:=350, Top:=100, Height:=230)
    With chartObuject.Chart
        .ChartType = xlColumnClustered
        .HasTitle = True
        .HasLegend = True
        .SetSourceData Source:=Sheets("Sheet1").Range("A5:H5")
        .ChartTitle.Characters.Text = "Welder Performance Per Joint - Per Welder"
        
        With .Legend
            .Position = xlLegendPositionRight
            .Top = 45
            .Height = 75
            .Width = 155
        End With
End With
    
    'wks.SaveAs (flname)
    rst.Close
    Set rst = Nothing

 

[hendy13]

i already solve my third problem. this is my final result image :



thanks mh123 for guiding me to solve my ms.access problem

 

[mh123]

No problem - glad to be of assistance!