excel 是否有vba代码将值从一列移动到另一列(如果为空)?

zdwk9cvp  于 2023-06-07  发布在  其他
关注(0)|答案(4)|浏览(227)

如果列a为空,我如何将值从列a复制到列B

Sub pretify()

Dim cell As Range
For Each cell In Range("Table1[[a]:[b]]")
    If cell("Table1[a]").Value = Empty Then cell.Value = cell("Table1[b]").Value
Next

End Sub

我试图复制值从一列到其他,如果它的空

afdcj2ne

afdcj2ne1#

可能是以下内容:

Sub pretify()

    Dim col1 As ListColumn, col2 As ListColumn
    Set col1 = ActiveSheet.ListObjects("Table1").ListColumns("a")
    Set col2 = ActiveSheet.ListObjects("Table1").ListColumns("b")

    Dim cell As Range, counter As Long
    For Each cell in col1.DataBodyRange
        counter = counter + 1
        If IsEmpty(cell.Value) Then
            cell.Value = col2.DataBodyRange.Cells(counter).Value
        End If
    Next

End Sub

或者直接使用Range s:

Sub pretify()

    With ActiveSheet.LIstObjects("Table1")
        Dim col1 As Range, col2 As Range
        Set col1 = .ListColumns("a").DataBodyRange
        Set col2 = .ListColumns("b").DataBodyRange
    End With

    Dim cell As Range, counter As Long
    For Each cell in col1
        counter = counter + 1
        If IsEmpty(cell.Value) Then
            cell.Value = col2.Cells(counter).Value
        End If
    Next

End Sub
woobm2wo

woobm2wo2#

填充空单元格

Sub FillEmptyCells()
    Const PROC_TITLE As String = "Fill Empty Cells"
    On Error GoTo ClearError
    
    Const TABLE_NAME As String = "Table1"
    Const SRC_LIST_COLUMN As Variant = "b" ' fill from
    Const DST_LIST_COLUMN As Variant = "a" ' flll

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    If Not wb Is ActiveWorkbook Then wb.Activate

    Dim rg As Range: Set rg = Range(TABLE_NAME)
    
    Dim srg As Range, drg As Range
    
    With rg.ListObject
        Set srg = rg.Columns(.ListColumns(SRC_LIST_COLUMN).Index)
        Set drg = rg.Columns(.ListColumns(DST_LIST_COLUMN).Index)
    End With
    
    Dim rCount As Long: rCount = rg.Rows.Count
    
    Dim sData, dData
    
    If rCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1).Value = srg.Value
        ReDim dData(1 To 1, 1 To 1): dData(1, 1).Value = drg.Value
    Else
        sData = srg.Value
        dData = drg.Value
    End If
    
    Dim r As Long, IsFound As Boolean
    
    For r = 1 To rCount
        If IsEmpty(dData(r, 1)) Then
            If Not IsFound Then
                IsFound = True
            End If
            dData(r, 1) = sData(r, 1)
        End If
    Next r
    
    If IsFound Then
        drg.Value = dData
        MsgBox "Empty cells filled.", vbInformation, PROC_TITLE
    Else
        MsgBox "No empty cells found.", vbExclamation, PROC_TITLE
    End If

ProcExit:
    Exit Sub
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub
fjnneemd

fjnneemd3#

在本例中,如果目标单元格为空,则将值从表的一列(源)复制到另一列(目标)。我不使用单元格复制,因为在大规模的数据是缓慢的,但在过滤目标列中的空单元格后,从源列复制相关数据:

' THE dst is the header of destination column
' THE src is the header of source column
Public Sub filterEmptyCells_AndCopyFrom(dst As Range, src As Range, Optional criteria As String = "=")
   Dim fltr As Range, ar As Range, lo As ListObject, ci As Long
   Dim cDif As Long
   
   ' get the TABLE under the header of destination column
   Set lo = dst.ListObject
   
   ' get the index of destination header in table columns
   ci = lo.ListColumns(dst.Value2).Index
   
   ' calculate the distance (in columns) between the source column and destination column
   cDif = src.Column - dst.Column
   
   ' with the destination column
   With lo.ListColumns(ci).Range
      ' clear the old filters
      .AutoFilter
      
      ' set the filter (optional parameter => default "=") at column ci
      .AutoFilter Field:=ci, Criteria1:=criteria
      
      ' exclude the header of column (offset),  resize to fit in Table, get the visible (filtered cells)
      'Set fltr = .Offset(1, 0).Resize(.Rows.CountLarge - 1, 1).SpecialCells(xlCellTypeVisible)
      
      ' or is simpler use DatabodyRange instead of Range
      Set fltr = lo.ListColumns(ci).DataBodyRange.SpecialCells(xlCellTypeVisible)
      ' remove the filters
      .AutoFilter
      
      ' THE CELLS WE FOUND MAYBE ARE NOT CONTINOUS
      ' ITERATE THE AREAS AND COPY FROM THE RELATIVE POSITION THE VALUES
      ' ONE BY ONE AREA    ----  not one by one cell
      For Each ar In fltr.Areas
         ar.Value2 = ar.Offset(0, cDif).Value2
      Next
   End With
End Sub

' execute the Sub to do the copy
Sub copyInitiator()
   Application.ScreenUpdating = False
   'CHANGE => SHEET15.Range("C8"), SHEET15.Range("D8") according to your own design
   
   Call filterEmptyCells_AndCopyFrom(SHEET15.Range("C8"), SHEET15.Range("D8"))
End Sub

twh00eeo

twh00eeo4#

为什么不使用一个简单的公式,就像下面的例子:
公式:=IF(NOT(ISBLANK(A1)),A1,"")
截图:

相关问题