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
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
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
' 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
4条答案
按热度按时间afdcj2ne1#
可能是以下内容:
或者直接使用
Range
s:woobm2wo2#
填充空单元格
fjnneemd3#
在本例中,如果目标单元格为空,则将值从表的一列(源)复制到另一列(目标)。我不使用单元格复制,因为在大规模的数据是缓慢的,但在过滤目标列中的空单元格后,从源列复制相关数据:
twh00eeo4#
为什么不使用一个简单的公式,就像下面的例子:
公式:
=IF(NOT(ISBLANK(A1)),A1,"")
截图: