VBA-Excel查找列名，返回它们的编号并在函数中使用列字母

我在VBA很新。 我已经在excel中使用了一对macros，但是这个比我高。 我正在寻找创build一个macros，将find适当的列，然后基于这个列中的值，更改另外三列中的值。 我已经有一个静态macros：

Sub AdjustForNoIntent() 'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No Dim lastrow As Long Dim i As Long lastrow = Range("AE" & Rows.Count).End(xlUp).Row For i = 2 To lastrow If Not IsError(Range("AE" & i).Value) Then If Range("AE" & i).Value = "No" And Range("U" & i).Value = "MEM" Then Range("U" & i).Value = "C-MEM" Range("Y" & i).ClearContents Range("AJ" & i).Value = "N/A" ElseIf Range("AE" & i).Value = "No" And Range("U" & i).Value = "VCH" Then Range("U" & i).Value = "C-VCH" Range("Y" & i).ClearContents Range("AJ" & i).Value = "N/A" End If End If Next i End Sub 

但是这是一个共享工作簿，所以人们随机添加列，每次需要返回代码并修改列引用。 我想要的是，例如，在A3行中查找具有“angular色”标题的列，并将其插入macros查找列“U”的地方。 这样，其他用户可以添加/删除列，但我不会每次都修改macros。

在其他的macros，我设法有这个东西的工作：

 Function fnColumnNumberToLetter(ByVal ColumnNumber As Integer) fnColumnNumberToLetter = Replace(Replace(Cells(1,ColumnNumber).Address, "1", ""), "$", "") End Function Dim rngColumn As Range Dim ColNumber As Integer Dim ColName As String ColName = "Email Address" Sheets("Tracking").Select Set rngColumn = Range("3:3").Find(ColName) ColNumber = Sheets("Tracking").Range(rngColumn, rngColumn).Column Sheets("Combined").Range(ActiveCell, "W2").FormulaLocal = "=IF(ISERROR(INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0))), INDEX(Tracking!$A:$A,MATCH(U:U,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)), INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)))" 

但是，我无法将后者链接到第一个，也不能将其find多个列。 任何帮助表示赞赏。

编辑：以下build议，这里是新的代码。 不会返回错误，但也不会执行任何操作。 它循环通过c循环确定，但是从For i =2 ...行跳转到End Sub 。

  Sub Adjust() Dim lastrow As Long Dim i As Long Dim headers As Dictionary Dim c As Long Set headers = New Scripting.Dictionary For c = 1 To Cells(3, Columns.Count).End(xlToLeft).Column headers.Add Cells(3, c).Value, c Next c lastrow = Cells(headers.Item("Survey: Interest to Participate") & Rows.Count).End(xlUp).Row For i = 2 To lastrow If Not IsError(Cells(i, headers.Item("Survey: Interest to Participate")).Value) Then If Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "MEM" Then Cells(i, headers.Item("Role")).Value = "C-MEM" Cells(i, headers.Ittem(" Follow-up date")).ClearContents Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A" ElseIf Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "VCH" Then Cells(i, headers.Item("Role")).Value = "C-VCH" Cells(i, headers.Ittem(" Follow-up date")).ClearContents Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A" End If End If Next i End Sub 

Answer 1

我会这样做的方式是创build一个Dictionary的标题名称作为键和列号作为值：

 Dim headers As Dictionary Set headers = New Scripting.Dictionary Dim c As Long 'Assuming headers are in row 1 for sake of example... For c = 1 To Cells(1, Columns.Count).End(xlToLeft).Column headers.Add Cells(1, c).Value, c Next 

然后，使用“ Dictionary集合，并使用“ Dictionary按列号对其进行索引，然后根据标题查找它，而不是使用硬编码列字母。 例如，如果你的代码需要列“U”在这个标题下：

 Range("U" & i).Value = "C-MEM" 

你可以用像这样的Dictionary来replace它，像这样的Dictionary ：

 Cells(i, headers.Item("Role")).Value = "C-MEM" 

请注意，这需要引用Microsoft脚本运行时（工具 – >引用…然后选中该框）。

Answer 2

但是这是一个共享工作簿，所以人们随机添加列，每次需要返回代码并修改列引用。

保护工作簿以防止这种不受欢迎的行为？

我个人更喜欢使用命名范围，这将调整插入和重新sorting的数据列。

从公式function区，定义一个新名称：

然后，通过一个简单的程序确认您可以移动，插入等，如下所示：

 Const ROLE As String = "Role" Sub foo() Dim rng As Range Set rng = Range(ROLE) ' This will display $B$1 MsgBox rng.Address, vbInformation, ROLE & " located:" rng.Offset(0, -1).Insert Shift:=xlToRight ' This will display $C$1 MsgBox rng.Address, vbInformation, ROLE & " located:" rng.Cut Application.GoTo Range("A100") ActiveSheet.Paste ' This will display $A$100 MsgBox rng.Address, vbInformation, ROLE & " located:" End Sub 

所以，我会为每个列定义一个命名范围（目前假设为AE，U，Y和AJ）。 命名范围可以跨越整个列，这将尽量减less对代码其余部分的更改。

给定4个命名范围，如：

• angular色，代表U栏U：U
• RevProfile，代表AJ栏：AJ
• FollowUp，代表Y列：Y
• 意图，代表栏AE：AE

（ 注意：如果你预计用户可以在你的标题行之上插入行 ，那么我会把命名范围的赋值改变为只有标题单元格，例如“$ AE $ 1”，“$ U $ 1”等。下面的代码不需要额外的修改）

你可以这样做：

 'Constant strings representing named ranges in this worksheet Public Const ROLE As String = "Role" Public Const REVPROFILE As String = "RevProfile" Public Const FOLLOWUP As String = "FollowUp" Public Const INTENT As String = "Intent" Sub AdjustForNoIntent() 'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No Dim lastrow As Long Dim i As Long lastrow = Range(INTENT).End(xlUp).Row For i = 2 To lastrow If Not IsError(Range(INTENT).Cells(i).Value) Then If Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "MEM" Then Range(ROLE).Cells(i).Value = "C-MEM" Range(FOLLOWUP).ClearContents Range(REVPROFILE).Cells(i).Value = "N/A" ElseIf Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "VCH" Then Range(ROLE).Cells(i).Value = "C-VCH" Range(FOLLOWUP).Cells(i).ClearContents Range(REVPROFILE).Value = "N/A" End If End If Next End Sub 

Answer 3

我会和David Zemens一起回答，但你也可以使用Range().Find正确的列。

在这里，我重构了代码来查找和设置对列标题的引用。 一切都基于相对于这些参考。

在这里，我设置了一个对“调查”列的第3行的引用，其中的列标题是：

Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)

因为一切都是相对的，所以最后一行是实际的最后一行rSurvey的行

lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row

由于rSurvey是一个范围，我们知道rSurvey.Cells(1, 1)是我们的列标题。 不明显的是，因为rSurvey是一个范围rSurvey(1, 1)也是我们的列标题，因为列和行索引是可选的rSurvey(1)也是列标题单元格。

知道我们可以像这样迭代每列中的单元格

 For i = 2 To lastrow rSurvey( i ) 

---

 Sub AdjustForNoIntent() 'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No Dim lastrow As Long Dim i As Long Dim rRev As Range 'AJ Dim rRole As Range 'U Dim rFollowUp As Range 'Y Dim rSurvey As Range 'AE With Worksheets("Tracking") Set rRev = .Rows(3).Find(What:="REV", MatchCase:=False, Lookat:=xlWhole) Set rRole = .Rows(3).Find(What:="Role", MatchCase:=False, Lookat:=xlWhole) Set rFollowUp = .Rows(3).Find(What:="Follow-up", MatchCase:=False, Lookat:=xlWhole) Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole) lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row End With For i = 2 To lastrow If Not IsError(rSurvey(i).value) Then If rSurvey(i).value = "No" And rRole(i).value = "MEM" Then rRole(i).value = "C-MEM" rFollowUp(i).ClearContents rRev(i).value = "N/A" ElseIf rSurvey(i).value = "No" And rRole(i).value = "VCH" Then rRole(i).value = "C-VCH" rFollowUp(i).ClearContents rRev(i).value = "N/A" End If End If Next i End Sub