从 Col B 不为空的同一行下复制第三个单元格

Question

我一直在尝试创建一个函数来检查如果 Col"B" <> Empty 然后复制同一行下的第三个单元格。

我有这个数据：

我想从哪里复制 Col“D”突出显示的单元格并将它们粘贴到 Col“B”<> 为空的同一行。

这是最终结果。在这方面您的帮助将不胜感激。

Option Explicit
Sub CopyPasting()
    
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
        
        Set ws = ThisWorkbook.Sheets("Sheet1")
        With ws
            LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
            
        For r = LastRow To 2 Step -2
                If .Cells(r, "B") <> "" Then
                .Rows(r + "D").Copy
                .Rows(r + "D").PasteSpecial
    
            n = n + 1
            End If
            Next
    End With
    End Sub

Answer 1

我不确定您想要输出的位置，这会将其放入名为“Sheet2”的 sheet 中。（您必须在运行它不会为您创建的代码之前创建它。）

    Dim i As Long
    Dim j As Long
    Dim lr As Long
    Dim srcWS As Worksheet
    Dim destWS As Worksheet
    
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set destWS = ThisWorkbook.Sheets("Sheet2")
    
    With srcWS
        lr = .Cells(.Rows.Count, 4).End(xlUp).Row
        j = 2
        For i = 2 To lr
            If .Cells(i, 2).Value <> "" Then
                destWS.Cells(j, 1).Value = .Cells(i, 2).Value
                destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
                j = j + 1
            End If
        Next i
    End With

如果您还需要复制颜色，请使用此方法：

.Cells(i, 4).Offset(2, 0).Copy
destWS.Cells(j, 2).PasteSpecial xlPasteAll

而不是：

destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value

Answer 2

请尝试下一个代码：

Sub testRetOffset3()
  Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
  Set sh = ActiveSheet  'use here the sheet you need
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
  On Error Resume Next  'if not empty cells in column, it will not return the range and raise an error
  Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
  On Error GoTo 0
  If rngV Is Nothing Then Exit Sub  'stop the code if run on a wrong sheet, without empty cells in column B:B
  For Each c In rngV.cells          'iterate between the discontinuous range cells
    If rngFin Is Nothing Then       'if the final range is not set (first time)
        Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
    Else
        Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
    End If
  Next
  If Not rngFin Is Nothing Then  'copy both ranges in consecutive columns
        rngV.Copy sh.Range("F2")  
        rngFin.Copy sh.Range("G2")
  End If
End Sub

它将 return 列 F:G，从第二行开始。很容易修改范围return...

您甚至可以在 B:C 或另一个 sheet.

中清除现有的已处理列和 return

已编辑：为了解决上一个请求，请使用下一个代码：

Sub testRetOffsetMoreRows()
  Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
  Set sh = ActiveSheet
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
  On Error Resume Next
  Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
  On Error GoTo 0
  If rngV Is Nothing Then Exit Sub
  For Each A In rngV.Areas  'iterate between the range areas
    If rngFin Is Nothing Then
        Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
    Else
        Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
    End If
  Next
  If Not rngFin Is Nothing Then
        rngV.Copy sh.Range("H2")
        rngFin.Copy sh.Range("L2")
  End If
End Sub

但是当 B:B 列中有值时，请注意具有连续范围。否则，代码可能会失败...区域属性将 return 不同。

从 Col B 不为空的同一行下复制第三个单元格

Copy 3rd Cell from under Same Row Where Col B is not empty

excel

vba

copy

offset