在 VBA 中使用单元格值参考来确定范围
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/15885118/
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
Use Cell Value Reference in VBA to determine range
提问by Dm3k1
I know this is a pretty basic question, but im still working on building my VBA skills. I am in a predicament where I have made a mapping system of various reports I receive that get placed in a compiled workbook. These reports have entirely different formats etc. I have a copy/paste macro that copies columns and places them in their correct position on the compiled workbook.
我知道这是一个非常基本的问题,但我仍在努力培养我的 VBA 技能。我处于困境,我制作了一个映射系统,将我收到的各种报告放在一个编译好的工作簿中。这些报告具有完全不同的格式等。我有一个复制/粘贴宏,可以复制列并将它们放在已编译工作簿上的正确位置。
I've come into situations however where there are a lot of duplicate / empty rows that screw up my Macro. I have used two VBA functions to solve this, one is a "delete row if reference column is blank":
然而,我遇到过很多重复/空行搞砸了我的宏的情况。我使用了两个 VBA 函数来解决这个问题,一个是“如果引用列为空则删除行”:
Sub DeleteBlankARows()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, 6).End(xlUp).Row To 1 Step -1
If Cells(r, 6) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With End Sub
This deletes rows where cells in column F are empty
这将删除 F 列中的单元格为空的行
I also use a copy/paste down macro:
我还使用复制/粘贴宏:
Sub CopyUntilBlank()
Dim last_row As Integer
last_row = Range("f1").End(xlDown).Row
Dim rng As Range
Set rng = Range("d2:d" & last_row)
For Each cell In rng.Cells
cell.Activate
If ActiveCell.Value = "" Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End If
Next cell End Sub
This copies and pastes down blank rows in column D until you hit a non-blank cell then re-does this until the range of values in column F.
这会复制并粘贴 D 列中的空白行,直到您遇到非空白单元格,然后重新执行此操作,直到 F 列中的值范围。
These macros work well for me, but because I have multiple sheets like this, I would like to create a cell references that make the ranges dynamic. For instance: in the DeleteBlankRows macro, I would like to have the column reference in Cells(r,6) be determined off of a cell value in sheet1 - so for instance if the value in cell A1 on sheet 1 is 2 it would change the column reference to "2" (column B).
这些宏对我来说效果很好,但是因为我有多个这样的工作表,所以我想创建一个使范围动态化的单元格引用。例如:在 DeleteBlankRows 宏中,我希望 Cells(r,6) 中的列引用由 sheet1 中的单元格值确定 - 例如,如果工作表 1 上的单元格 A1 中的值是 2 它会改变列引用“2”(B 列)。
I would like the same to happen for the copy/paste down macro. I'm pretty sure this is just some reference to A1.Value but I don't know how to properly write such thing.
我希望复制/粘贴宏也能发生同样的情况。我很确定这只是对 A1.Value 的一些参考,但我不知道如何正确编写这样的东西。
Thank you for your support, I've gone quite a long way with all the support of the community.
感谢您的支持,在社区的所有支持下,我已经走了很长一段路。
回答by Tim Williams
An example using your first sub:
使用您的第一个子程序的示例:
Sub DeleteBlankARows(colIndex as Long)
Dim colIndex as long
colIndex = Sheet1.Range("a1").value
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, colIndex).End(xlUp).Row To 1 Step -1
If Cells(r, colIndex) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
It's not clear from your question which column in the second sub needs to be dynamic (or both of them?)
从您的问题中不清楚第二个子中的哪一列需要是动态的(或两者都需要?)
EDITtry this:
编辑试试这个:
Sub CopyUntilBlank()
Dim last_row As Long, col1 as Long, col2 as Long
Dim rng as Range
col1 = Sheet1.Range("a2").value
col2 = Sheet1.Range("a3").value
last_row = Cells(1, col1).End(xlDown).Row
'This next line is better if there's any chance
' of blanks in this column
'last_row = Cells(Rows.Count, col1).End(xlUp).Row
With ActiveSheet
Set rng = .Range(.Cells(2, col2), .Cells(last_row, col2))
End With
For Each cell In rng.Cells
If cell.Value = "" Then
cell.Value = cell.Offset(-1, 0).Value
End If
Next cell
End Sub