VBA 输入值大于 sheet 清除并复制没有空白行到另一个 sheet

Question

我的 2010 宏在打开 sheet 时更新。当他们在新 'instance' 中打开目标 sheet 时，2016 年的工作方式是否相同？它必须是白痴证明（我不知道他们为什么要我这样做 :P）。所以宏在打开sheet时必须运行一次；如果每次在源 sheet 中插入超过 119 的值时 sheet 在第二个监视器运行上打开；不要运行不必要，因为 sheet 和笔记本电脑可能非常大。

我制作了这个宏，因此我的大学正在使用的 sheet 不需要 'complex' 公式或宏在导出到 Word 之前清除空白行。我在 2010 年做到了，但我无法在下周之前的 2016 年对其进行测试。

目标上的宏 sheet (J03);

Private Sub worksheet_activate()

并在来源上 sheet (WTB)；

 Private Sub Run_When_Value_Greather_Than_119_Is_Entered_In_Column_G()

Google 塞满了关于空白行、复制、空白行、运行ning 其他激活方式和非空白行的答案和结果。我可能也不知道要寻找什么。

完整代码；

Private Sub worksheet_activate()
  Dim Max As Long, MaxD As Long       'Determine the amount of filled rows
  Dim wsWtB As Worksheet, wsJ03 As Worksheet
  Dim wb As Workbook
  Dim i As Integer, j As Integer      'i and j for the row numbers

  Application.ScreenUpdating = False  'screenupdating of for max speeds

  Set wb = ThisWorkbook
  Set wsJ03 = Sheets("J_03")
  Set wsWtB = Sheets("WTB")

  Max = WorksheetFunction.Max(wsWtB.Range("A3:A1600"))  'Amount of rows with data
  Max = Max + 3                                         'Ignore the headers
  MaxD = WorksheetFunction.Max(wsJ03.Range("A3:A1600"))
  MaxD = MaxD + 2
  j = 9                   'The rownumber where the copying needs to start
    wsJ03.Range("B9", Cells(MaxD, 5)).ClearContents  'Clear the old values
      For i = 3 To Max    'The copying loop has to start after the headers at row 3
        If wsWtB.Cells(i, 7).Value > 119 Then   'Do stuff if...
          wsJ03.Cells(j, "B").Value = Chr(39) & wsWtB.Cells(i, "B").Value 'At a  '
          wsJ03.Cells(j, "C").Value = Chr(39) & wsWtB.Cells(i, "C").Value 'at the start
          wsJ03.Cells(j, "D").Value = Chr(39) & wsWtB.Cells(i, "D").Value 'so a zero is
          wsJ03.Cells(j, "E").Value = Chr(39) & wsWtB.Cells(i, "E").Value 'displayed
          j = j + 1       'Set the next row for the target sheet
        Else
      End If
    Next i
  Application.ScreenUpdating = True
End Sub

这是我顺利完成的第一段代码 :-) 欢迎发表评论并添加 propper 标签。

科恩。

编辑；（寻找最后一个单元格的替代方法）

?thisworkbook.sheets("WTB").cells(rows.Count,"A").end(xlup).row
  1047 '<- Rownumber of the last cell with a Formula to create/force 
        successive 
        numbers
?thisworkbook.sheets("WTB").columns("A").Find(What:="*", LookIn:=xlValues, 
 SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
  5    '<- Rownumber of the last cell with a value. Includes the header 
        rows
?WorksheetFunction.Max(thisworkbook.sheets("WTB").Range("A3:A1600"))
  3    '<- Highest number in A3:A1600 and also the amount units/rows that 
        need to be copied to "J_03"

我需要一个函数来为我提供 sheet 上的 'things' 数量。在这种情况下它是 3，但它可能会上升到 1600。

编辑2；（google sheet 所以你可以看到我在做什么） https://docs.google.com/spreadsheets/d/1I5qLeOS0DWcwncs_ium_J0Vp6b4nzTsiE0ndbKtpsC0/edit?usp=sharing

编辑3；清晰范围部分有错误。 wsJ03.Range("B9", Cells(MaxD, 5)).ClearContents '清除旧值

Answer 1

您可以使用类似下面的内容，但请确保将代码放在 Sheet 中值可能会发生变化的位置 (Sheets("WTB")):

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 7 Then 'If something changed in column G
        If Target.Value > 119 Then 'and if the value is higher than 119
        NextFreeRow = Sheets("J_03").Cells(.Rows.Count, "B").End(xlUp).Row + 1
        'Or Do your copying stuff, you can use Target.column or Target.row to find the address of the cell that got a value higher than 119
            Sheets("J_03").Cells(NextFreeRow, "B").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "B").Value 'At a  '
            Sheets("J_03").Cells(NextFreeRow, "C").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "C").Value 'at the start
            Sheets("J_03").Cells(NextFreeRow, "D").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "D").Value 'so a zero is
            Sheets("J_03").Cells(NextFreeRow, "E").Value = Chr(39) & Sheets("WTB").Cells(Target.Row, "E").Value 'displayed
        End If
    End If
End Sub

Answer 2

2 个月后，我想展示我的最终作品；

Union() 函数让您（在这种情况下是我）提高工作表的速度：

For i = 1 to LastRow
  If Ws1.Cells(i, 1).Value > 119 Then
    Union(Ws2.Cells(i, 4), Ws2.Cells(i, 5), Ws2.Cells(i, 6)).Value = 
    Union(Ws1.Cells(y, 1), Ws1.Cells(y, 2), Ws1.Cells(y, 3)).Value: y = y + 1
  end if
Next

它比使用 cel1, 2, 3.value = cel5, 6, 7.value 快大约 30%，当它只是复制没有 If 的所有行时。

当我的工作簿需要像这样填充 50 张纸并且有 25 行数据时，平均需要 4.5 秒，而 Union() 是 1.6 秒。当有 1000 行时，它从大约 23 秒变为 9 秒，但变化非常大。取决于 If's;

对于某些工作表，它不是 "If > 119 then"；

If cellAL.Value = "x" Then     'if the cell exactly "x" Then do stuf
If Not cellAL.Value <> vbNullString Then   'if the cell = NotEmpty 
                                            vbNullString 
                  is faster then "" because it's actually less ones and zeros
If InStr(cellAll, "x") Then     'looks for all x's in the cell.

查找不受格式、公式和其他因素影响的最后一行；

myLastRow = .Columns("A").Find(What:="*", LookIn:=xlValues, _
             SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

"*" 'is something like "any/all characters". A Space or Alt + Enter can make 
                                             a big mess

尝试直接 window 看看它的作用：

?activesheet.Columns("A").Find(What:="*", LookIn:=xlValues, _ 
                               SearchDirection:=xlPrevious).Row

Ps 我的 CanaDerp 伙伴；希望你能使用它！

VBA 输入值大于 sheet 清除并复制没有空白行到另一个 sheet

VBA Clear and Copy without blank rows to another sheet on entering value greater than

excel

vba

copy-paste