Question

我正在尝试创建一个代码，其中工作簿中的某些行被复制到不同的工作簿。使用的标准是如果在这些行中，列F没有特定值（因此不是值1,2或3）则复制。我无法让它发挥作用。有人可以帮忙吗？

Dim copysheet As Worksheet
Dim pastesheet As Worksheet
Dim Cell As Range

Set copysheet = ActiveWorkbook.Worksheets(1)
Set pastesheet = Workbooks("Workbook1").Worksheets(1)

copysheet.UsedRange.Select
For Each Cell In Selection
    If Not Cell.Value = "Value1" Then
        If Not Cell.Value = "Value2" Then
            If Not Cell.Value = "Value3" Then
                ActiveCell.EntireRow.Copy
                pastesheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
        End If
    End If
Next

Answer 1

我会使用excel的过滤器选项。

这样的事情：

numberofrows = WorksheetFunction.CountA（表格（＆＃34; Sheet1＆＃34;）。范围（＆＃34; A：A＆＃34;））

表格（＆＃34; Sheet1＆＃34;）。范围（表格（＆＃34; Sheet1＆＃34;）。单元格（1，i），表格（＆＃34; Sheet1＆＃34;）。单元格（ numberofrows，i））。AdvancedFilter Action：= xlFilterCopy，CopyToRange：= Sheets（＆＃34; Sheet2＆＃34;）。Range（＆＃34; A1＆＃34;），Unique：= True

表格（＆＃34; Sheet1＆＃34;）。范围（表格（＆＃34; Sheet1＆＃34;）。单元格（1,1），表格（＆＃34;表格（＆＃34; Sheet1＆＃） 34;）。单元格（1,1））。自动筛选字段：= 1，条件1：=数组（表格（＆＃34; Sheet2＆＃34;）。单元格（1,1），表格（＆＃34; Sheet2＆＃ 34。）细胞（2,1），...）

表格（＆＃34; Sheet1＆＃34;）。单元格（1,1）.CurrentRegion.Copy（工作簿（＆＃34; Nike DRS＆＃34;）。表格（＆＃34; Sheet1＆＃34;） .Cells（1,1））

Answer 2

Option Base 1
Sub t()
Application.DisplayAlerts = False

Dim NewSheet As Worksheet
Dim calsheet As Worksheet
Dim myarr()
Dim myarr1()

myarr1 = Array(1, 2)  'Change the array values which you want to exclude

With ThisWorkbook.Sheets("FINAL DATASET") ' change the raw data sheet name here
    .AutoFilterMode = False
    Set calsheet = ThisWorkbook.Sheets("cal")

    If calsheet Is Nothing Then
            Set NewSheet = ThisWorkbook.Sheets.Add
            NewSheet.Name = "cal"
        Else
            ThisWorkbook.Sheets("cal").Delete
            Set NewSheet = ThisWorkbook.Sheets.Add
            NewSheet.Name = "cal"
    End If

    .Columns("f").Copy
    NewSheet.Range("a1").PasteSpecial (xlPasteValues)
    NewSheet.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes

        For Each cell In NewSheet.Range("a1:a" & NewSheet.Range("a" & Rows.Count).End(xlUp).Row).Cells
            i = i + 1

                For Counter = 1 To UBound(myarr1)
                    If cell.Value = myarr1(Counter) Then
                        k = k + 1
                    End If
                Next Counter

                If IsEmpty(k) Then k = 0

                If i <> 1 And k = 0 Then
                    j = j + 1
                    ReDim Preserve myarr(j)
                    myarr(j) = cell.Value
                End If

                k = 0

        Next cell

    .Rows(1).AutoFilter field:=.Range("f1").Column, Criteria1:=myarr, Operator:=xlFilterValues
End With        

 End Sub

VBA使用多个if副本复制到另一个工作表

2 个答案: