请大神帮忙，把（D列）状态。.......

刷卡机电脑监控 · 发表于 2024-9-10 15:59

请VBA大神帮忙，把（D列）状态，带（蓝色表格数字）的整行，复制到（新表）的表里。D列状态（蓝色表格）为“完”和“0”的不用复制。

Excel_muke · 发表于 2024-9-10 16:25

1.按ALT+F11，进入VBA窗口；

2.双击左边ThisWorkbook，输入：

Sub CopyRowsWithBlueBackground()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRowSrc As Long
Dim lastRowTgt As Long
Dim targetRow As Long
Dim cell As Range
Dim blueColor As Long
' 设置蓝色的RGB值
blueColor = RGB(0, 176, 240) ' 使用RGB函数，也可以直接使用长整型值 &H0000FF& 或 16711680
' 设置源工作表和目标工作表
Set wsSource = ThisWorkbook.Sheets("所有比赛")
Set wsTarget = ThisWorkbook.Sheets("新表")
' 获取源工作表的最后一行
lastRowSrc = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
' 获取目标工作表的最后一行
lastRowTgt = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
' 初始化目标工作表的目标行
targetRow = lastRowTgt + 1
' 遍历源工作表的每一行
For i = 1 To lastRowSrc
' 检查D列单元格的颜色和值
Set cell = wsSource.Cells(i, 4) ' D列为第4列
If cell.Interior.Color = blueColor And Not (cell.Value = "完" Or IsNumeric(cell.Value) And cell.Value = 0) Then
' 如果背景色为蓝色且值不是"完"或0，则复制整行
wsSource.Rows(i).Copy wsTarget.Rows(targetRow)
targetRow = targetRow + 1 ' 更新目标行
End If
Next i
MsgBox "操作完成！"
End Sub

复制代码

3.按ALT+Q退出,新建按钮控件，指定宏

kuangben8 · 发表于 2024-9-10 16:32

D列白色底纹的行怎么处理？

杨建营 · 发表于 2024-9-10 16:38

请楼主参考。

ykcbf1100 · 发表于 2024-9-10 16:59

附件供参考。。。

ykcbf1100 · 发表于 2024-9-10 17:00

参与一下。。。

Sub ykcbf() '//2024.9.10
With Sheets("所有比赛")
r = .Cells(Rows.Count, 1).End(3).Row
c = .Cells(1, "XFD").End(1).Column
ReDim brr(1 To r, 1 To c)
For i = 2 To r
Set Rng = .Cells(i, 4)
If Rng.Interior.ColorIndex <> xlNone Then
If Rng.Value <> 0 And Rng.Value <> "完" Then
m = m + 1
For j = 1 To c
brr(m, j) = .Cells(i, j).Value
Next
End If
End If
Next
End With
With Sheets("新表")
.UsedRange.Offset(1).ClearContents
.[a2].Resize(m, c) = brr
.[a2].Resize(m, c).Borders.LineStyle = 1
End With
MsgBox "OK！"
End Sub

复制代码

usedrange · 发表于 2024-9-10 17:06

Sub tt()
Dim ar, i%, m%, n%, s
With Sheets("所有比赛")
m = .[a1].End(xlToRight).Column
.[a1].Resize(1, m).Copy Sheets("新表").[a1].Resize(1, m)
Set ar = .[a1].Resize(.[a1].End(4).Row - 1, m)
For i = 2 To UBound(ar.Value)
If ar(i, 4).Interior.ColorIndex = 33 And ar(i, 4).Value <> "完" Then
If ar(i, 4).Value <> 0 Then
Set s = ar(i, 1).Resize(1, m)
With Sheets("新表")
n = .[a10000].End(xlUp).Row + 1
.Cells(n, 1).Resize(1, m) = s.Value
End With
Set s = Nothing
End If
End If
Next i
Set ar = Nothing
End With
End Sub

复制代码

quqiyuan · 发表于 2024-9-10 17:13

参与一下，复制工作表，然后再删除的方法，保持跟源表格式一致，仅供参考。。。

quqiyuan · 发表于 2024-9-10 17:14

代码如下。。。。
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = ThisWorkbook
Set sht = wb.Sheets("所有比赛")
On Error Resume Next
Set sh = wb.Sheets("新表")
sh.Delete
On Error GoTo 0
sht.Copy after:=sht
With ActiveSheet
      .Name = "新表"
      For i = .Cells(Rows.Count, 4).End(3).Row To 2 Step -1
         If .Cells(i, 4) = "完" Or .Cells(i, 4) = 0 Then .Rows(i).EntireRow.Delete
         If .Cells(i, 4).Interior.Color <> RGB(0, 176, 240) Then .Rows(i).EntireRow.Delete
      Next
      .Cells.Borders.LineStyle = xlNone
      .[a1].CurrentRegion.Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Beep
End Sub

gwjkkkkk · 发表于 2024-9-10 19:27

Option Explicit
Sub TEST1()
Dim ar, i&, Rng As Range

With [A1].CurrentRegion
      ar = .Value
      For i = 2 To UBound(ar)
         If .Rows(i).Interior.ColorIndex <> xlNone Then
            If ar(i, 4) <> "完" And ar(i, 4) <> 0 Then
                  If Rng Is Nothing Then
                     Set Rng = .Rows(i)
                  Else
                     Set Rng = Union(Rng, .Rows(i))
                  End If
            End If
         End If
      Next i
End With

With Worksheets(2)
      .[A1].CurrentRegion.Offset(1).Clear
      If Not Rng Is Nothing Then Rng.Copy .[A2]
      .Activate
End With
Beep
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 请大神帮忙，把（D列）状态。.......

评分

评分

评分