Блог

Если вы посмотрите на мой код, я просто зациклился на том, как использовать расширенную фильтрацию. для столбца A, если он равен введенной дате, а столбец E равен ACH или > 0, я хочу скопировать столбец B в столбец D на другом листе, столбец D в столбец F и столбец E в столбец C на другом листе. Как это можно переписать

В настоящее время у меня есть этот код, который проходит через весь лист на основе введенной даты TextBox1.value и нескольких других критериев.

 Private Sub CommandButton1_Click()    
    Dim RawData As String, RawDataWorkingFolder As String, myrange As Range, cell As Range
    Dim targetSheetName As String
    Dim targetSheetFound As Boolean
    Dim sheet As Worksheet
    Set aw = ActiveWorkbook
    Dim RawDataWorkingFolder2 As String, RawData2 As String
    
    Set myrange = Worksheets("Sheet1").Range("INFO")
    Unload Me
    BD = TextBox1.Value
    
    a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    Application.ScreenUpdating = FALSE
    RawDataWorkingFolder = Trim(aw.Worksheets(1).Range("A1").Value)
    RawData = Trim(aw.Worksheets(1).Range("E1").Value)
    Call Utilities.OpenWorkbook(RawDataWorkingFolder amp; RawData)
    
    For i = 2 To a
        If myrange.Cells(i, 1).Value = DateValue(BD) Then        'And myrange.Cells(i, 1).value <= DateValue(ED) Then
            If myrange.Cells(i, 5).Value = "ACH" Or myrange.Cells(i, 5).Value > 0 And myrange.Cells(i, 5).Value < 1000000 Then
                des = myrange.Cells(i, 2)
                Value = myrange.Cells(i, 4)
                ACH = myrange.Cells(i, 5)
                Worksheets("DAILY").Range("D" amp; Rows.Count).End(xlUp).Offset(1) = des
                Worksheets("DAILY").Range("F" amp; Rows.Count).End(xlUp).End(xlUp).Offset(1) = Value
                Worksheets("DAILY").Range("C" amp; Rows.Count).End(xlUp).Offset(1) = ACH
            
            ElseIf myrange.Cells(i, 5).Value = "CREDIT" Then
                des = myrange.Cells(i, 2)
                Value = myrange.Cells(i, 3) * -1
                ACH = myrange.Cells(i, 5)            
                Worksheets("DAILY").Range("D" amp; Rows.Count).End(xlUp).Offset(1) = des
                Worksheets("DAILY").Range("F" amp; Rows.Count).End(xlUp).End(xlUp).Offset(1) = Value
                Worksheets("DAILY").Range("C" amp; Rows.Count).End(xlUp).Offset(1) = ACH
            
            End If
        End If
    
        Application.StatusBar = "Data Is Running... Percentage complete Is " amp; Round((i / a * 100), 0) amp; "%"
    Next

Call Utilities.CloseWorkbook(RawData)
 

Мне было интересно, могу ли я использовать расширенный метод фильтрации или это более быстрый способ сделать это. Если да, пожалуйста, любой пример или помощь были бы замечательны. Прямо сейчас я нажимаю «Обновлять ежедневно», и появляется текстовое поле, в котором я ввожу дату, необходимую для копирования данных. Все работает просто медленно. Я хотел бы скопировать столбцы B, C, D и E на другой лист. Мои критерии должны заключаться в том, чтобы его ACH, КРЕДИТ или любое число выше 0 и дата совпадали с введенной датой, а затем скопировать информацию. Спасибо.

Вот способ использования расширенного фильтра для выполнения того, что вам требуется. Вам придется адаптировать мой код к вашим особенностям.

Я ввел дату для фильтрации в поле ввода, но вы можете сделать это по-другому (и также должны подтвердить, что была введена фактическая дата).

Я использую некоторую область «в стороне» на рабочем листе для диапазона критериев.

Надеюсь, код достаточно прокомментирован, чтобы вы могли его понять.

 Option Explicit
Sub copyFiltered()
'declare all variables
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rData As Range
    Dim rCriteria As Range
    Dim myDate As Date
    
'get date to be filtered
myDate = InputBox("Enter date of interest:")

'set worksheets and ranges
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")

With ws1
    Set rData = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=5)
    Set rCriteria = Range("AA1:AB3") 'could be anyplace on the worksheet
End With

'populate the criteria range
With rCriteria
    'Date Criteria: column A
    .Cells(1, 1) = rData(1, 1)
    .Cells(2, 1) = myDate
    .Cells(3, 1) = myDate
    
    'Column E criteria
    .Cells(1, 2) = rData(1, 5)
    .Cells(2, 2) = "ACH"
    .Cells(3, 2) = ">0"
    
End With

'Apply the filter
rData.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=rCriteria

'Copy the filtered data to the appropriate columns on the destination sheet
'might want to clear the destination sheet first
ws2.Cells.Clear
With rData
    .Columns(2).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(1, 4)
    .Columns(4).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(1, 6)
    .Columns(5).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(1, 3)
End With

'Remove the filter
ws1.ShowAllData
     
End Sub
 

Исходные Данные

Результаты после фильтрации