时间戳

首页 > 解决方案 > 如何将可见的自动筛选行插入另一个工作表（不包括标题）

excel - 如何将可见的自动筛选行插入另一个工作表（不包括标题）

问题描述

我正在尝试自动过滤（在 SHEET 1 的 A 列中）SHEET 2中的活动单元格。然后我有一个计算可见行数的 IF 语句，如果它大于 1（排除标题），那么我想在SHEET 3中插入​​一个新行并剪切并粘贴自动过滤行的值在SHEET 1中进入SHEET 3中的新行。

然后我清除 SHEET 1 中的 Auto Filter ，并在SHEET 1中插入一个新行，并将活动单元格的行的值从SHEET 2剪切并粘贴到SHEET 1的新行中。如果 SHEET 1 中的 Auto Filter 没有结果，则 ELSE STATEMENT 清除SHEET 1中的 Auto Filter ，将新行插入 SHEET 1 并将 Active Cell's Row 的值从SHEET 2剪切并粘贴到新行中在表 1中。

目前，如果SHEET 2中的自动筛选结果在任何行 > 第 2 行中，我似乎无法让我的代码工作。这是我当前的代码，我已评论以帮助导航：

Sub Autofilter_Macro()

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet

Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3

Dim rng As Range

Dim AC As Integer
AC = ActiveCell.Row

sh1.AutoFilterMode = False 'Clears any AutoFilters from Sheet1

sh1.Range("A:A").Autofilter Field:=1, Criteria1:=ActiveCell.Value 'AutoFilters SHEET 1 column "A" based off the ActiveCell Row in SHEET 2

Set rng = sh1.UsedRange.SpecialCells(xlCellTypeVisible) 'Sets rng to visible cells

'    If (rng.Rows.Count > 1) Then 'Counts the # of visible rows
    If rng.Areas.Count = 2 Then

        sh3.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row (with the same format as the one below it) into row 2 of SHEET 3

'        sh3.Range("A2:CK2").Value = rng.Offset(rowOffSet:=1).Value 'Sets the new empty row's values in SHEET 3 = the values of the Autofiltered row in SHEET
        rng.Rows(2).Value.Cut sh3.Range("A2")

        sh1.ShowallData 'Clears any Autofilters from SHEET 1

        sh1.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row (with the same format as the one below it) into row 2 of SHEET 1

        sh1.Range("A2:CK2").Value = sh2.Range(Cells(AC, 1), Cells(AC, 89)).Value 'Sets the new empty row's values in SHEET 1 = the values of the ActiveCell row in SHEET 2

        MsgBox "Replaced Main Database" 'MsgBox indicating what has executed

    Else

        sh1.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row (with the same format as the one below it) into row 2 of SHEET 1

        sh1.Range("A2:CK2").Value = sh2.Range(Cells(AC, 1), Cells(AC, 89)).Value 'Sets the new empty row's values in SHEET 1 = the values of the ActiveCell row in SHEET 2

        MsgBox "New Entry into Main Database"

    End If

sh1.ShowallData 'Clears any Auotfilters from SHEET 1


End Sub

感谢 CDP1802 在下面的回答，这是供任何人参考的最终代码：

Sub Autofilter_Macro()

    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet                       'Declares variables as worksheets
    Dim rng As Range                                                               'Declares variable as a range to store values

    Set sh1 = Sheet1                                                               'Assigns a worksheet to the declared worksheet variable (sh1 = "Main Database" Worksheet = Machine Inv #)
    Set sh2 = Sheet2                                                               'Assigns a worksheet to the declared worksheet variable (sh 2 = "Changes" Worksheet)
    Set sh3 = Sheet3                                                               'Assigns a worksheet to the declared worksheet variable (sh 3 = "Historical Parameters" Worksheet)

    Dim rowAC As Long, rowCut As Long                                              'Declares variable and assigns it as a Long data type
    rowAC = ActiveCell.Row                                                         'Sets the Long variable as the Active Cell Row

    If Len(ActiveCell.Value) = 0 Then                                              'Tests if the Active Cell in column A (Key) of the "Changes" Worksheet is blank or not

        MsgBox "Blank Key in:" & ActiveCell.Address, vbCritical                    'If the Active Cell is blank, then this MsgBox notifies you that it's blank
        Exit Sub                                                                   'Ends the entire Macro if the Active Cell is Blank

    End If                                                                         'Doesn't initiate the MsgBox and continues the Macro if the Key in Column A is not blank

    sh1.AutoFilterMode = False                                                     'Clears any Autofilters (if any) in Sheet 1
    sh1.Range("A:A").Autofilter Field:=1, Criteria1:=ActiveCell.Value              'Autofilters Sheet 1 for the Active Cell (Key) from Sheet 2 ("Changes" Worksheet)

    Set rng = sh1.UsedRange.SpecialCells(xlCellTypeVisible)                        'Sets the range varaible to visible cells in Sheet 1 (Main Database)

    If rng.Areas(1).Rows.Count > 1 Then                                            'Tests if the Active Cell (Key) from Sheet 2 (Changes) is in Row 2 of Sheet 1

        rowCut = rng.Areas(1).Rows(2).Row                                          'If the key is present, stores the values of Row 2 in Sheet 1 as a variable called "rowCut"

    ElseIf rng.Areas.Count > 1 Then                                                'Tests if the Active Cell (Key) from Sheet 2 (Changes) is present in any Row of Sheet 1 (Excluding Row 1 "The Header", and Row 2)

        rowCut = rng.Areas(2).Rows(1).Row                                          'If the key is present, stores the values of the row that has the Active Cell "Key" in Sheet 1 as a variable called "rowCut"

    End If                                                                         'If the Key is not present in Sheet 1, the variable "rowCut" will not hold any values and be equal to zero

    sh1.ShowallData                                                                'Clears Autofilters in Sheet 1

    If rowCut > 0 Then                                                             'If the variable "rowCut" was succesful in holding a row's values from Sheet 1, then the following executes:

        sh3.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row into Sheet 3 Row 2 w/ same format as the row below it
        sh1.Rows(rowCut).Copy sh3.Range("A2")                                      'Copies the Active (Cell) Row from Sheet 1 (Main Database) & pastes it into the empty row 2 in Sheet 3 (Historical Parameters)
        sh1.Rows(rowCut).Delete                                                    'Deletes the Active (Cell) Row from Sheet 1

    End If                                                                         'If the variable "rowCut" was unsuccesful in holding a row's values from Sheet 1, then nothing will happen to Sheet 3 (Historical Parameters)

        sh1.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts an empty row into Sheet 1 Row 2 w/ same format as the row below it
        sh2.Range("A" & rowAC & ":CK" & rowAC).Copy sh1.Range("A2")                'Copies the Active (Cell) Row from Sheet 2 (Changes) & pastes it into the empty row 2 in Sheet 1
        sh2.Range("A" & rowAC & ":CK" & rowAC).Delete                              'Deletes the Active (Cell) Row from Sheet 2

End Sub

标签： excelvbaautofilter

解决方案

问题是可见范围是不连续的，例如 "$A$1:$D$1,$A$6:$D$6" 所以 rng.Offset(rowOffSet:=1) 总是会给出 $A$2:$D$2 . Range 有一个area 属性。使用 rng.areas.count 你可以做类似的事情

If rng.Areas.Count = 1 Then
   sh3.Range("A2:CK2").Value = rng.Offset(rowOffSet:=1).value
Else
   sh3.Range("A2:CK2").Value = rng.Areas(2).value     
End If

这是我使用的测试程序

Sub test()
    Dim rng As Range
    With ThisWorkbook.Sheets("Sheet1")
      Set rng = .UsedRange.SpecialCells(xlCellTypeVisible)
    End With
    If rng.Areas.Count > 1 Then
       Debug.Print "Rng", rng.Address
       Debug.Print "Rng Offset", rng.Offset(rowOffSet:=1).Address
       Debug.Print "rng Area(2)", rng.Areas(2).Address
    Else
       Debug.Print "rng", rng.Address
       Debug.Print "rng offset", rng.Offset(rowOffSet:=1).Address
    End If
End Sub

编辑 - 将该原则纳入您的代码中，我得到

Sub Autofilter_Macro()

    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
    Dim rng As Range

    Set sh1 = Sheet1
    Set sh2 = Sheet2
    Set sh3 = Sheet3

    Dim rowAC As Long, rowCut As Long
    rowAC = ActiveCell.Row

    If Len(ActiveCell.Value) = 0 Then
       MsgBox "Blank value in " & ActiveCell.Address, vbCritical
       Exit Sub
    End If

    MsgBox "Value = " & ActiveCell.Value

    'AutoFilters SHEET 1 column "A" based off the ActiveCell Row in SHEET 2
    sh1.AutoFilterMode = False
    sh1.Range("A:A").AutoFilter Field:=1, Criteria1:=ActiveCell.Value

    'Sets rng to visible cells
    Set rng = sh1.UsedRange.SpecialCells(xlCellTypeVisible)
    If rng.Areas(1).Rows.Count > 1 Then
         rowCut = rng.Areas(1).Rows(2).Row
    ElseIf rng.Areas.Count > 1 Then
         rowCut = rng.Areas(2).Rows(1).Row
    End If
    sh1.ShowAllData 'Clears any Auotfilt

    If rowCut > 0 Then
        'Inserts an empty row into Sheet 3 Row 2
        'with the same format as the one below it
        'copy/paste/delete filter row to sheet3
        sh3.Rows("2:2").Insert Shift:=xlDown, _
            CopyOrigin:=xlFormatFromRightOrBelow

        sh1.Rows(rowCut).EntireRow.Copy
        sh3.Activate
        sh3.Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        sh1.Activate
        'sh1.Range("A" & rowCut).Interior.Color = vbRed
        sh1.Rows(rowCut).Delete
    End If

    'insert row in sheet1 and copy from sheet2
    sh1.Rows("2:2").Insert Shift:=xlDown, _
        CopyOrigin:=xlFormatFromRightOrBelow

    sh2.Range("A" & rowAC & ":CK" & rowAC).Copy
    sh1.Range("A2").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

End Sub

推荐阅读