使用公式 VBA 过滤和填充可见单元格
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/42061837/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Filter and Fill visible cells with formula VBA
提问by Anne
I was wondering if there is a way of going through a filter list. for each filtered list I will perform a formula. i.e
我想知道是否有办法通过过滤器列表。对于每个过滤列表，我将执行一个公式。IE
Company Name Invoice Number Voucher Number
CompanyA 000001 TX100
CompanyA 000001 //copy what's on top
CompanyA 000001 //copy what's on top
CompanyB 000002
CompanyB 000002
CompanyC 000003 TY909
CompanyC 000003 //copy what's on top
Basically I need to filter the column company name(Range A filter) as you can notice for each company name some rows of voucher rows values are missing I just need to fill it with the same voucher number so it'll be like ...
基本上我需要过滤列公司名称（范围A过滤器），因为您可以注意到每个公司名称缺少一些凭证行值的行我只需要用相同的凭证编号填充它，所以它就像......
Company Name Invoice Number Voucher Number
CompanyA 000001 TX100
CompanyA 000001 TX100
CompanyA 000001 TX100
CompanyB 000002
CompanyB 000002
CompanyC 000003 TY909
CompanyC 000003 TY909
I want output to be like that notice I don't need to fill for those that doesn't have voucher number i.e CompanyB
我希望输出像这样的通知我不需要填写那些没有凭证编号的通知，即 CompanyB
I've tried this code without filtering each company ...
我试过这个代码没有过滤每家公司......
Range("V2:V" & xRow).SpecialCells(xlCellTypeVisible).Formula = "=IF(J2<>"""",J2,IF(V1="""","""",V1))"
Range("V2:V" & xRow).SpecialCells(xlCellTypeVisible).Value = Range("V2:V" & xRow).SpecialCells(xlCellTypeVisible).Value
Range("V1:V" & xRow).SpecialCells(xlCellTypeVisible).Copy
Range("J1").PasteSpecial Paste:=xlPasteValues
the dilemma is it copies everything on top of if so it'll be like
困境是它复制所有内容，如果是这样，它会像
Company Name Invoice Number Voucher Number
CompanyA 000001 TX100
CompanyA 000001 TX100
CompanyA 000001 TX100
CompanyB 000002 TX100
CompanyB 000002 TX100
CompanyC 000003 TY909
CompanyC 000003 TY909
which is wrong. any help? or improvements.
这是错误的。有什么帮助吗？或改进。
Update:I've tried using filter
更新：我试过使用过滤器
Sub try()
Dim currRng As Range, dataRng As Range, currCell As Range
Dim xRow As Long
xRow = Cells(rows.Count, "A").End(xlUp).row
With ActiveSheet
Set currRng = .Range("A1", .Cells(.rows.Count, "A").End(xlUp))
Set dataRng = .Range("V2:V" & xRow)
' Range("AF:XFD").Delete
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.Value = Range("I2").Value
dataRng.SpecialCells(xlCellTypeVisible).Formula = "=IF(I2<>"""",I2,IF(V2="""","""",V2))"
dataRng.Value = dataRng.Value
dataRng.Copy Destination:=Range("I2")
dataRng.ClearContents
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
range("V:V") is where I'm storing/dumping my formula, Range("I:I") is the column range where Voucher number is stored, but I still get no result or null. I need to filter every company and from that company if the first row result of that company is null make it all null (say in CompanyB in my sample) and if it does have a value (like my sample ng CompanyA and CompanyC) fill those down.
range("V:V") 是我存储/转储我的公式的地方， Range("I:I") 是存储凭证编号的列范围，但我仍然没有得到结果或为空。如果该公司的第一行结果为空，则我需要过滤每家公司和该公司，使其全部为空（例如在我的样本中的 CompanyB 中），并且如果它确实具有值（如我的样本 ng CompanyA 和 CompanyC），则填充这些下。
采纳答案by Anne
Upon trying several times I've come up with this code...
经过多次尝试，我想出了这段代码......
Sub voucher_num()
Dim cell As Range, currRng As Range, dataRng As Range, currCell As Range, destRng As Range
Dim xRow As Long
xRow = Cells(rows.Count, "A").End(xlUp).row
With ActiveSheet
Set currRng = .Range("A1", .Cells(.rows.Count, "").End(xlUp)) 'column range of my filter
Set dataRng = .Range("V2:V" & xRow) 'range of column I'm dumping my formula
Set destRng = .Range("I2:I" & xRow) 'storing again the values I've come up with from the formula
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.rows.Count)
.Value = currRng.Value
'.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter Field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Value = destRng.SpecialCells(xlCellTypeVisible).Value
dataRng.SpecialCells(xlCellTypeVisible).FillDown
dataRng.SpecialCells(xlCellTypeVisible).Value = dataRng.SpecialCells(xlCellTypeVisible).Value
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=destRng.SpecialCells(xlCellTypeVisible)
dataRng.SpecialCells(xlCellTypeVisible).ClearContents
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
This takes quite your time, I haven't come up with a better/faster approach but this is doing what I want.
这需要您花费大量时间，我还没有想出更好/更快的方法，但这正是我想要的。
回答by user3598756
edited after OP's clarifications about data placement:
在 OP 关于数据放置的澄清之后编辑：
you may use this
你可以用这个
Range("V2:V" & xRow).SpecialCells(xlCellTypeVisible).Formula =IF(I2<>"""",I2,IF(A2<>A1,"""",IF(U1="""","""",U1)))
回答by Sivaramakrishnan P
The below code helps to Copy and paste the formulas in visible cells only. Its working fine for me. You can put any other formulas too.
下面的代码有助于仅在可见单元格中复制和粘贴公式。它对我来说工作正常。您也可以输入任何其他公式。
Dim Xrow As Long, WS As Worksheet, dng As Range
Xrow = Cells(Rows.Count, "A").End(xlUp).Row
With ActiveSheet
Set WS = ActiveSheet
Set dng = .Range("H1:H" & Xrow)
WS.Range("A1:BD1" & Xrow).AutoFilter Field:=12, Criteria1:="Sheets"
Range("H1").Select
dng.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RC[1]"
End With
'To remove Autofilter ActiveSheet.ShowAllData
'删除自动过滤ActiveSheet.ShowAllData
'To copy and paste special values for columns use the below Columns.EntireColumn("H").Copy
'要复制和粘贴列的特殊值，请使用下面的 Columns.EntireColumn("H").Copy
Columns.EntireColumn("H").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
