Rectangle 27 2

In Access with DAO, this is how you'd do it:

Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim rsFiltered As DAO.Recordset

  Set db = CurrentDb
  Set rs = db.OpenRecordset("SELECT tblInventory.* FROM tblInventory;")
  rs.MoveLast
  Debug.Print "Unfiltered: " & rs.RecordCount

  rs.filter = "[LastUpdated]>=#1/1/2011#"
  Set rsFiltered = rs.OpenRecordset
  rsFiltered.MoveLast
  Debug.Print "Filtered: " & rsFiltered.RecordCount

  rsFiltered.Close
  Set rsFiltered = Nothing
  rs.Close
  Set rs = Nothing
  Set db = Nothing

However, note that (as mentioned in the help file), it may be just as fast to simply reopen the recordset with new criteria, instead of filtering the existing recordset.

Interesting; I didn't know about the .Filter property. I'll have to check this out and see if it's faster than what I came up with.

excel - How do I copy and filter a DAO recordset in VBA? - Stack Overf...

excel ms-access vba dao recordset
Rectangle 27 1

Dim rs_clone As Variant

...

rs_clone = rs.getrows(numrows)

then process the resulting 2-d array.

Sign up for our newsletter and get our top new questions delivered to your inbox (see an example).

excel - How do I copy and filter a DAO recordset in VBA? - Stack Overf...

excel ms-access vba dao recordset
Rectangle 27 0

Well, through trial and error I got it working! Yeeey! Don't know why, but it only works if I reference the Sheet4 as Worksheets(1). Here is the code that works for my purpose:

Private Sub Find_Click()
Dim wbData As Range
Dim wbCriteria As Range
Dim wbExtract As Range

Set wbData = Workbooks("GAL_db.xlsx").Worksheets("data").Range("A1")
Set wbCriteria = ThisWorkbook.Worksheets(1).Range("V1:AE2")
Set wbExtract = ThisWorkbook.Worksheets(1).Range("E1:T1")

        wbData.CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=wbCriteria, CopyToRange:=wbExtract, Unique:=False

End Sub

Excel VBA: Advanced Filter to copy data to another workbook - Stack Ov...

excel vba excel-vba
Rectangle 27 0

Private Sub CopyRange()

    Dim r1 As Range
    Dim r2 As Range

    Set r1 = ActiveSheet.Range("A1:C1,A3:C3")
    Set r2 = ActiveSheet.Range("D5")

    r1.Copy r2

End Sub

As a side note, you can use advanced filter in the code or in excel and specify a range for it to be copied to.

excel - Copy/paste filtered cells vba - Stack Overflow

excel vba
Rectangle 27 0

  • Make a new column.
=IF(ISNUMBER(SEARCH("-",B1)),"Match","")

Sort the table using your new column. Then you can copy & paste.

excel - Copy/paste filtered cells vba - Stack Overflow

excel vba
Rectangle 27 0

You need a function that translate the frequency text to a number of months (lets call it MonthFreq returning an integer).

MaxDate = DateSerial(2013, 4, 1)
Do Until Origin.Cells(OriginRow, NameColumn).Value = ""
    SourceDate = Origin.Cells(OriginRow, DateColumn).Value
    Do Until SourceDate >= MaxDate
        ' Copy origin row to destiny.
        Destiny.Cells(DestinyRow, DateColumn).Value = SourceDate

        SourceDate = DateAdd("m", MonthFreq(Origin.Cells(OriginRow, FreqColumn).Value), SourceDate)
        DestinyRow = DestinyRow + 1
    Loop
    OriginRow = OriginRow + 1
Loop

Origin is the worksheet with the original data, Destiny is the worksheet where the expanded data will be saved. OriginRow is the current row being analyzed in the Origin worksheet (starts at the first row). OriginColumn is the current row being written in the Destiny worksheet (starts at the first row). SourceDate will be added some number of months until it reaches the MaxDate.

Thanks for this - forgive my ignorance but say my origin cell was simply the active cell and I wanted to paste the data in the rows directly below it - i.e. for my example of Dave (quarterly) if the active cell is A10, I would like to paste the three additional rows of data below this?

Excel 2007 VBA copy rows x times based on text filter - Stack Overflow

vba excel-vba copy excel-2007
Rectangle 27 0

Offset
ActiveSheet.Range("A1:AR1617").Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy

Above code copies the filtered data excluding the header. Is this what you're trying?

Yes that is what I am trying to achieve.

You can at least accept it by marking the check :)

Excel VBA filtering and copy pasting data - Stack Overflow

excel vba excel-vba
Rectangle 27 0

I've got a quick VBA procedure that will do just what you want...

Private Sub MultiFilter(DataRange As Range, CriteriaRange As Range, OutputRangeTL As Range)
    Dim intRowCounter As Integer
    Dim intColCounter As Integer
    Dim varCurrentValue As Variant
    Dim blnCriteriaError As Boolean
    Dim rngOutputCurrent As Range

    If CriteriaRange.Columns.Count <> DataRange.Columns.Count Then
        Err.Raise Number:=513, Description:="CriteriaRange and DataRange must have same column count"
    End If
    If CriteriaRange.Rows.Count <> 2 Then
        Err.Raise Number:=513, Description:="CriteriaRange must be of 2 rows"
    End If

    Set rngOutputCurrent = OutputRangeTL.Resize(1, DataRange.Columns.Count)

    For intRowCounter = 1 To DataRange.Rows.Count
        For intColCounter = 1 To DataRange.Columns.Count
            varCurrentValue = DataRange.Cells(intRowCounter, intColCounter).Value
            If Not (varCurrentValue >= CriteriaRange.Cells(1, intColCounter) _
            And varCurrentValue <= CriteriaRange.Cells(2, intColCounter)) Then
                ''#i.e. criteria doesn't match
                blnCriteriaError = True
                Exit For
            End If
        Next intColCounter
        If Not blnCriteriaError Then
            ''#i.e. matched all criteria
            rngOutputCurrent.Value = DataRange.Resize(1).Offset(intRowCounter - 1).Value
            Set rngOutputCurrent = rngOutputCurrent.Offset(1)
        End If
        blnCriteriaError = False
    Next intRowCounter
End Sub
DataRange:
0 0 0
1 1 0
2 0 3
2 2 1

CriteriaRange:
1 0 0
2 1 10
Public Sub DoTheFilter()
    MultiFilter Range("MyDataRange"), Range("MyCriteriaRange"), Range("MyOutputRangeTopLeft")
End Sub

The CriteriaRange is simply a 2 row range giving minimum and maximum values for each column.

This isn't the most elegant of most efficient way I'm sure, but I used it as a quick fix as I've needed to do this once or twice.

If you're not comfortable with using VBA code then let me know and I'm sure I can manage to convert it into a worksheet function for you (this would also have the added advantage of updating if you changed the criteria...)

How can I filter and copy data in Excel? - Stack Overflow

excel filter
Rectangle 27 0

If you don't need to remember the filters, you only need a single line of code:

Sub UnfilterMe(Sheet As Worksheet)
    Sheet.AutoFilterMode = False
End Sub

Excel VBA: copying all rows in a range including any hidden by a filte...

excel vba filter copy
Rectangle 27 0

I think you are looking for a combination of the 2 solutions you had...

Private Sub Find_Click()
Set wbSearch = ThisWorkbook
Set wbData = Workbooks("GAL_db.xlsx")

        wbData.Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy,
        CriteriaRange:=wbSearch.Sheets("Sheet4").Range("V1:AE2"), CopyToRange:=wbSearch.Sheets("Sheet4").Range("E1:T1"), Unique:=False

End Sub
wbData.Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy,

what is the exact error you are receiving? Maybe a screenshot?

getting the "Compile Error: Syntax Error"

Excel VBA: Advanced Filter to copy data to another workbook - Stack Ov...

excel vba excel-vba
Rectangle 27 0

You have a typo in your code:

dataWB.Worksheet(1)
dataWB.Worksheets(1)

The error raises because there is now Worksheet property/method for the Workbook object.

excel - Advanced Filter to copy on another workbook - Stack Overflow

excel vba excel-vba
Rectangle 27 0

should be

ActiveSheet.Range(Cells(1, 1), Cells(countRow, 7)).Select

Woops. Thanks for that. My cells don't seem to be filtering or getting rid of duplicates though... any help?

select nonblank cells, filter, and copy and paste excel vba - Stack Ov...

excel excel-vba excel-2007
Rectangle 27 0

Option Compare Database

Private Sub Command0_Click()
Sub Export_Click()

Dim db As Database, rs As Recordset, sql As String, r As Variant

Dim appExcel As Excel.Application
Dim excelWbk As Excel.Workbook
Dim excelSht As Object
Dim rng As Excel.Range

Set appExcel = New Excel.Application
On Error Resume Next
Set excelWbk = appExcel.Workbooks.Open("Folder Name(Template)")

Set db = CurrentDb()
sql1 = "Select * from Query_New"
sql2 = "Select * from Query_Expired"
Set rs1 = db.OpenRecordset(sql1, dbReadOnly)
Set rs2 = db.OpenRecordset(sql2, dbReadOnly)

Dim SheetName1 As String
Dim SheetName2 As String

SheetName1 = "New"
SheetName2 = "Expired"

'For first sheet
On Error Resume Next
excelWbk.Sheets(SheetName1).Select

If Err.Number <> 0 Then
MsgBox Err.Number
excelWbk.Close False
appExcel.Quit
Exit Sub
End If

With excelWbk.Activesheet
    .Cells(5, 1).CopyFromRecordset rs1
    On Error GoTo 0
End With

'For second sheet
On Error Resume Next
excelWbk.Sheets(SheetName2).Select

If Err.Number <> 0 Then
MsgBox Err.Number
excelWbk.Close False
appExcel.Quit
Exit Sub
End If

With excelWbk.Activesheet
    .Cells(5, 1).CopyFromRecordset rs2
    On Error GoTo 0
End With


rs1.Close
Set rs1 = Nothing
rs2.Close
Set rs2 = Nothing
db.Close
Set db = Nothing

On Error Resume Next

excelWbk.SaveAs "C:\Documents and settings\" & Environ("UserName") & "\Desktop\Decision.xlsx"

If Err.Number <> 0 Then
MsgBox Err.Number
End If

excelWbk.Close False
appExcel.Quit
Set appExcel = Nothing
MsgBox "The report has been saved"
End Sub




End Sub

excel - How do I copy and filter a DAO recordset in VBA? - Stack Overf...

excel ms-access vba dao recordset
Rectangle 27 0

Since it's only the first row that seems to be the problem, you could copy THAT row column by column, but copy the remaining rows by entire row:

Sub DataCopy()
    Dim r As Range
    Dim dest As Range
    For Each r In Names("DateSet").RefersToRange.Rows
        If r.Row = 2 Then
            For Each c In r.Columns
                Set dest = Worksheets(2).Cells(r.Row, c.Column)
                r.Cells(1, c.Column).Copy dest
            Next
        Else
            Set dest = Worksheets(2).Cells(r.Row, r.Column)
            r.Copy dest
        End If
    Next
End Sub

Thanks, but I'm not sure it's usable in my real problem with many thousand rows and 20 columns.

OK, see my revised answer, which only copies the first row one cell at a time, but does the remaining cells a row at a time.

No - it's all visible rows in the dataset that have the problem.

I tested the code I posted and it is returning 5 rows of 4 columns each as you said you were getting without the filter. Try it out and let me know if it's still not right.

I think I will go another way around the problem. I think I will unhide all columns before copying rows and hide them againg after after my copy. I don't need help for that.

Excel VBA copy from af filtered list with hidden column - Stack Overfl...

excel-vba excel-2007 excel-2010
Rectangle 27 0

Firstly a few helpful points:

  • If you want to work with VBA then my advice is to avoid merged cells like the plague. They cause havoc with code. If possible use format cells - alignment - horizontal - centre accross selection
  • I also advise avoiding loops wherever possible and take advantage of excels built in functions instead as a good practice exercise.

Here is my solution. Keep it simple. If you need further help let me now.

Sub HTH()

    Dim rCopy As Range

    With Sheet1.AutoFilter.Range
        '// Set to somewhere blank and unused on your worksheet
        Set rCopy = Sheet1.Range("A" & Rows.Count - (.Rows.Count))
        .SpecialCells(xlCellTypeVisible).Copy rCopy
    End With

    With rCopy.Offset(1).Resize(5) '// Offset to avoid the header
        .Resize(, 2).Copy Sheet2.Range("A5")
        .Offset(, 3).Resize(, 1).Copy Sheet2.Range("D5")
        .Offset(, 5).Resize(, 1).Copy Sheet2.Range("F5")
        .CurrentRegion.Delete xlUp '// Delete the tempory area
    End With

    Set rCopy = Nothing

End Sub

1. That's interesting, I didn't know that! Will definitely look at using that in the future. 2. Sorry mate, merged cells is not my choice. For the moment that is something I can't change. 3. Yup. I agree. But you also have to work with what you know and right now I don't know a lot ;-)

With a little bit of twiddling, I was able to understand which bit of the code did what and bend it to my will. Thanks very much. It was quite simple and I liked the lack of loops.

Great, glad it worked for you. Yes sometimes merged cells are unavoidable, just make them a last resort. So also are loops but avoiding them where possible usually will result in faster execution of code as your taking advantage of excels builtin features.

Excel VBA: Filter and copy from top 5 rows/cells - Stack Overflow

excel excel-vba
Rectangle 27 0

While it may simply be easier to loop through the first five visible rows, I used application.evaluate to process a worksheet-style formula that returned the row number of the fifth visible record.

Sub sort_filter_copy()
    Dim lr As Long, lc As Long, flr As Long, rws As Long, v As Long
    Dim sCRIT As String
    Dim vCOLs As Variant, vVALs As Variant
    Dim bCopyFormulas As Boolean, bSort2Keys As Boolean

    bCopyFormulas = True
    bSort2Keys = False
    sCRIT = "dave"
    vCOLs = Array(1, 2, 4, 6)

    With Sheet1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(4, Columns.Count).End(xlToLeft).Column
        With .Cells(5, 1).Resize(lr - 4, lc)
            'sort on column F as if there was no header
            If bSort2Keys Then
                .Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
                            Key2:=.Columns(7), Order2:=xlDescending, _
                            Orientation:=xlTopToBottom, Header:=xlNo
            Else
                .Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
                            Orientation:=xlTopToBottom, Header:=xlNo
            End If
            With .Offset(-1, 0).Resize(.Rows.Count + 1, .Columns.Count)
                .AutoFilter
                .AutoFilter field:=3, Criteria1:=sCRIT
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    rws = Application.Min(5, Application.Subtotal(103, .Columns(3)))
                    If CBool(rws) Then
                        flr = Application.Evaluate("=small(index(rows(5:" & lr & ") + ('" & Sheet1.Name & "'!C5:C" & lr & "<>" & Chr(34) & sCRIT & Chr(34) & ")*1e99, , ), " & rws & ")")
                        For v = LBound(vCOLs) To UBound(vCOLs)
                            If .Columns(vCOLs(v)).Cells(1).HasFormula And bCopyFormulas Then
                                Sheet2.Cells(3, vCOLs(v)).Resize(5, 1).FormulaR1C1 = _
                                    .Columns(vCOLs(v)).Cells(1).FormulaR1C1
                            Else
                                .Columns(vCOLs(v)).Resize(flr - 4, 1).Copy _
                                    Destination:=Sheet2.Cells(3, vCOLs(v))
                            End If
                        Next v
                    End If
                End With
                .AutoFilter
            End With
            'uncomment the next line if you want to return to a standard ascending sort on column A
            '.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
        End With
    End With
End Sub

All options are set just below the variable declarations. Your sample images seemed to indicate that you used a two key sort so I coded for that optionally. If you want to bring in any formulas as formulas, that option is there. The filter criteria and the columns to copy are assigned to their respective vars as well.

Excel VBA: Filter and copy from top 5 rows/cells - Stack Overflow

excel excel-vba
Rectangle 27 0

Sub GetTopFiveRows()
    Dim table As Range, cl As Range, cnt As Integer

    Set table = Worksheets("Sheet1").Range("A2:A10").SpecialCells(xlCellTypeVisible)
    cnt = 1

    With Worksheets("Sheet2")
        For Each cl In table
            If cnt <= 5 Then
                .Range("A" & cnt) = cl
                .Range("B" & cnt) = cl.Offset(0, 1)
                .Range("D" & cnt) = cl.Offset(0, 3)
                .Range("F" & cnt) = cl.Offset(0, 5)
                cnt = cnt + 1
            Else
                Exit Sub
            End If
        Next cl
    End With
End Sub
  • First a reference is set to only visible rows in the entire table (you'll need to update the range reference)
  • Then we loop over the visible range, copy to sheet 2, and stop when 5 records (i.e. the top five) have been copied

Excel VBA: Filter and copy from top 5 rows/cells - Stack Overflow

excel excel-vba
Rectangle 27 0

Wilhelm, asked a valid question. I am still going ahead and assuming that by saying 'Quarterly' you just want to add 4 months.

I am also assuming that (I guess I am correct on this one though) you want to keep on incrementing the dates till the time they are less than 1st March 2013 (immaterial of the fact whether it is ANNUAL, QUARTERLY or MONTHLY)

Please try this code. I am sure it can be made more perfect. ;)

Option Explicit

Sub Sample()
    Dim ws As Worksheet, ws1 As Worksheet
    Dim i As Long, j As Long, LastRow As Long
    Dim boolOnce As Boolean
    Dim dt As Date

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    '~~> Input Sheet
    Set ws = Sheets("Sheet1")
    '~~> Output Sheet
    Set ws1 = Sheets("Sheet2")
    ws1.Cells.ClearContents

    '~~> Get the last Row from input sheet
    LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

    boolOnce = True

    '~~> Loop through cells in Col A in input sheet
    For i = 2 To LastRow
        j = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1

        Select Case UCase(ws.Range("C" & i).Value)
            Case "ANNUAL"
                dt = DateAdd("yyyy", 1, ws.Range("D" & i).Value)
                '~~> Check if the date is less than 1st march 2013
                If dt <= #3/1/2013# Then
                    ws1.Range("A" & j & ":A" & j + 1).Value = ws.Range("A" & i).Value
                    ws1.Range("B" & j & ":B" & j + 1).Value = ws.Range("B" & i).Value
                    ws1.Range("C" & j & ":C" & j + 1).Value = ws.Range("C" & i).Value
                    ws1.Range("D" & j).Value = ws.Range("D" & j).Value
                    ws1.Range("D" & j + 1).Value = DateAdd("yyyy", 1, ws.Range("D" & i).Value)
                End If
            Case "QUARTERLY"
                dt = DateAdd("M", 4, ws.Range("D" & i).Value)
                Do While dt <= #3/1/2013#
                    ws1.Range("A" & j).Value = ws.Range("A" & i).Value
                    ws1.Range("B" & j).Value = ws.Range("B" & i).Value
                    ws1.Range("C" & j).Value = ws.Range("C" & i).Value
                    If boolOnce = True Then
                        ws1.Range("D" & j).Value = DateAdd("M", -4, dt)
                        boolOnce = False
                    Else
                        ws1.Range("D" & j).Value = dt
                    End If
                    dt = DateAdd("M", 4, ws1.Range("D" & j).Value)
                    j = j + 1
                Loop
                boolOnce = True
            Case "MONTHLY"
                dt = DateAdd("M", 1, ws.Range("D" & i).Value)
                Do While dt <= #3/1/2013#
                    ws1.Range("A" & j).Value = ws.Range("A" & i).Value
                    ws1.Range("B" & j).Value = ws.Range("B" & i).Value
                    ws1.Range("C" & j).Value = ws.Range("C" & i).Value
                    If boolOnce = True Then
                        ws1.Range("D" & j).Value = DateAdd("M", -1, dt)
                        boolOnce = False
                    Else
                        ws1.Range("D" & j).Value = dt
                    End If
                    dt = DateAdd("M", 1, ws1.Range("D" & j).Value)
                    j = j + 1
                Loop
                boolOnce = True
        End Select
    Next i

LetsContinue:
    Application.ScreenUpdating = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Thanks for this - the quarterly value was an error on my part, but I think given the structure it shouldn't be too tough to deal with! I have tested it and it does work, I just have to work out how it does its magic! :)

Would it be possible to ask how to use this function to also / instead just do this for the last row of data and paste underneath (so based on the sample use A5 as the active cell and past the 2 rows in A6 and A7)? Thanks!

Davin, this is where I am looping through the cells "For i = 2 To LastRow" you can always set it for A5. I am using the ws1 as the 2nd sheet for output. You can direct that to the current sheet :)

Sorry for ignorance here, but if I wanted A5 to be the active cell rather than a specific reference, and pasting the rows underneath (so taking it one case at a time instead), how would I modify the "For i=2 to lastrow" bit? Thanks :)

I can give you the answer but I want you to first understand the code :). "For i=2 to lastrow" loops from cell A2 to A(Lastrow). So If I just want to interact with A5 then what should we do? How should we write it so that it addresses only cell A5?

Excel 2007 VBA copy rows x times based on text filter - Stack Overflow

vba excel-vba copy excel-2007
Rectangle 27 0

=IF(ISERROR(SEARCH("-",B2)),"",B2)

Fill down the formula in Col A. Follow up with copy/pastespecial-values if you need to convert from a formula to a fixed value.

excel - Copy/paste filtered cells vba - Stack Overflow

excel vba
Rectangle 27 0

Dim cell As Range
Dim curPat As String

curpath = ActiveWorkbook.Path & "\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each cell In Range("fbtlist")
     [valsalesman] = cell.Value
     Range("myFBT").AdvancedFilter Action:=xlFilterCopy, _
    criteriarange:=Range("criteria"), copytorange:=("extract"), unique:=False
Range(Range("extract"), Range("extract").End(xlDown)).Copy
Workbooks.Add  'Instead of creating use the Workbook.open and perform as below
'You may insert this code to find the last used row
a = 2
do while cells(a, 2) <>""
a = a+1
loop
cells(a,1).select
Activesheet.paste
ActiveWorkbook.SaveAs Filename:=curpath & cell.Value & Format(Now, "ddmmyyyy - hhmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Range(Range("extract"), Range("extract").End(xlDown)).ClearContents
Next cell

End Sub

hey thanks, Yuvaraj. But lets say the criteria's name is "Criteria1" and i have workbook with a similliar name in my dir, is there a vba code that will match automatically the criteria name to the workbook and paste it there withtout me needing to do it one by one. There are around 10 workbooks and the criterias change often so it would be more easier for vba to do it.

excel - Copy filtered data into specific sheet - Stack Overflow

excel vba excel-vba