Question

我正在编写的VBA代码出现问题，以替换手动过程。

我几乎已经到了最后但是我正在努力获取代码以逐列为基础将我的过滤数据复制到新工作表（新工作表中的布局更改）。我目前的代码只是复制单元格C2中的数据。

有谁可以看看这个，看看我哪里出错了？我复制了以下代码的相关部分。

提前致谢

    'Copy formula down

 Range("F2:L2").Select
 Selection.Copy
 LR = Range("A" & Rows.Count).End(xlUp).Row
 Range("F2:L2").AutoFill Destination:=Range("F2:L" & LR), Type:=xlFillDefault

Application.CutCopyMode = False
Range("O1").goalseek Goal:=Range("Q1"), ChangingCell:=Range("U1")

'Add Filter
Range("A2").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$L$5000").AutoFilter Field:=12, Criteria1:= _
    "1"

'Move the data to the new sheet

Sheets("Sheet1").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
NextFree = Range("A2:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Range("A" & NextFree).SpecialCells(xlCellTypeVisible).Value2 = _
Worksheets("To Be Used").Range("C:C").SpecialCells(xlCellTypeVisible).Value2

'This part is only copying the data from cell C2 when I need it to copy all of the filtered data     in column C aprt from C1 and there is a long delay

Range("A" & NextFree).SpecialCells(xlCellTypeVisible).Value2 = _
Worksheets("To Be Used").Range("C2:C" & LR).SpecialCells(xlCellTypeVisible).Value2

Answer 1

我已经把你的代码搞得一团糟，但我担心自己无法充分测试.goalseek功能。过滤后的列C的过滤器和后续复制/粘贴按预期工作。

Dim rw As Long, ws As Worksheet
Set ws = Sheets("Sheet16")  'change the target worksheet name here
With Sheets("To Be Used").Cells(1, 1).CurrentRegion
    .Cells(2, 6).Resize(.Rows.Count - 1, 7).FillDown
    .Range("O1").GoalSeek Goal:=.Range("Q1"), ChangingCell:=.Range("U1")
    .AutoFilter
    .AutoFilter Field:=12, Criteria1:="1"
    If Application.Subtotal(103, .Columns(3)) > 1 Then
        rw = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _
          Destination:=ws.Cells(rw, 1)
        .Columns(1).Offset(1, 0).Resize(.Rows.Count - 1, 2).Copy _
          Destination:=ws.Cells(rw, 2)
        .Columns(4).Offset(1, 0).Resize(.Rows.Count - 1, 2).Copy _
          Destination:=ws.Cells(rw, 4)
    End If
    .AutoFilter
End With
Set ws = Nothing

将1列过滤数据复制到另一张表

1 个答案: