vba 如何使用列标题选择不同范围的单元格以从文件名填充数据

How to use column headers to select different ranges of cells to populate data from a filename

提问by Jonny

This is a separate question stemming from this post: How to use the filename of an excel file to change a column of cells?

这是源自这篇文章的一个单独问题：如何使用 excel 文件的文件名来更改一列单元格？

I noticed that in the last post's code it was referencing specific cells (J2,K2). However when using the code, I came into an error when the columns changed. So now I am seeking a way to modify the below code to use the names of the header columns to populate the 2nd column instead of referencing specific cells. I think the only line that really needs adjusting is the myRng line, but I will provide all the code I am trying for reference.

我注意到在上一篇文章的代码中它引用了特定的单元格（J2，K2）。但是，在使用代码时，当列更改时我遇到了错误。所以现在我正在寻找一种方法来修改下面的代码以使用标题列的名称来填充第二列而不是引用特定的单元格。我认为唯一真正需要调整的行是 myRng 行，但我将提供我正在尝试的所有代码以供参考。

In case you don't read the other post, I will describe the issue. I am trying to fill in the 2nd column (name+type) based on the "name" column and the filename. When I was referencing the K or J row in the code, everything was working fine, but when I load a different file and the columns positions have changed, everything gets messed up.

如果你没有阅读另一篇文章，我会描述这个问题。我正在尝试根据“名称”列和文件名填写第二列（名称+类型）。当我在代码中引用 K 或 J 行时，一切正常，但是当我加载不同的文件并且列位置发生变化时，一切都变得一团糟。

I need to populate the 2nd column (name+type) to be the exactly the same number or rows as the 1st column (name) which is why I am using the Range ("K2:K" & lastCell) formula.

我需要将第二列（名称+类型）填充为与第一列（名称）完全相同的数字或行，这就是我使用范围（“K2：K”和 lastCell）公式的原因。

Is there a way to do this?

有没有办法做到这一点？

Current Attempted VBA code:

当前尝试的 VBA 代码：

' Insert Column after name and then rename it name+type

Rows(1).Find("name").Offset(0, 1).EntireColumn.Insert
Rows(1).Find("name").Offset(0, 1).FormulaR1C1 = "name+type"

Dim myRng As Range
Dim lastCell As Long
Dim myOtherRange As Range
Dim column2Range As Range

myOtherRange = Rows(1).Find("name")
column2Range = Rows(1).Find("name+type")
lastCell = Range(myOtherRange).End(xlDown).Row
Set myRng = Range("K2:K" & lastCell)

myOtherRange.FormulaR2C1 = "=LEFT(MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1),5)&RC[-1]"
myOtherRange.FormulaR2C1.Select
Selection.Copy
myRng.Select
ActiveSheet.Paste

First Draft VBA code:

初稿 VBA 代码：

' Insert Column after name and then rename it name+type

Rows(1).Find("name").Offset(0, 1).EntireColumn.Insert
Rows(1).Find("name").Offset(0, 1).FormulaR1C1 = "name+type"


'Add the contents to the name+type column

Range("K2").Select
ActiveCell.FormulaR1C1 = "=LEFT(MID(CELL(""filename"",RC[-1]),SEARCH(""["",CELL(""filename"",RC[-1]))+1,SEARCH(""]"",CELL(""filename"",RC[-1]))-SEARCH(""["",CELL(""filename"",RC[-1]))-1),5)&RC[-1]"
Range("K2").Select
Selection.Copy
Range("K2:K8294").Select
ActiveSheet.Paste

回答by Siddharth Rout

@Scott or Siddharth Rout probably =) – Jonny 11 hours ago

@Scott 或 Siddharth Rout 可能 =) – Jonny 11 小时前

I would never recommend this :) SO is full of experts who can assist you. Why do you want to limit the help that you can get? ;)

我永远不会推荐这个:) SO 到处都是可以为您提供帮助的专家。为什么要限制您可以获得的帮助？;)

Is this what you are trying?

这是你正在尝试的吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, aCol As Long
    Dim aCell As Range

    Set ws = Sheets("Sheet1") '<~~ Change this to the relevant sheet name

    With ws
        Set aCell = .Rows(1).Find("Name")

        '~~> Check if the column with "name" is found
        If Not aCell Is Nothing Then
            aCol = aCell.Column
            .Columns(aCol + 1).EntireColumn.Insert
            .Cells(1, aCol + 1).Value = "Name+Type"
            .Activate

            .Rows(1).Select

            With ActiveWindow
                .SplitColumn = 0
                .SplitRow = 1
                .FreezePanes = True
            End With

            '~~> Get lastrow of Col which has "name"
            lRow = .Range(Split(.Cells(, aCol).Address, "$")(1) & .Rows.Count).End(xlUp).Row

            ThisWorkbook.Save

            '~~> Add the formula to all the cells in 1 go.
            .Range(Split(.Cells(, aCol + 1).Address, "$")(1) & "2:" & _
            Split(.Cells(, aCol + 1).Address, "$")(1) & lRow).Formula = _
            "=LEFT(MID(CELL(""filename"",RC[-1]),SEARCH(""["",CELL(""filename"",RC[-1]))+1," & _
            "SEARCH(""]"",CELL(""filename"",RC[-1]))-SEARCH(""["",CELL(""filename"",RC[-1]))-1),5)&RC[-1]"

            .Columns("A:AK").Columns.AutoFit
        Else
            MsgBox "Name Column Not Found"
        End If
     End With
End Sub

回答by Jonny

After modifying the code provided by Siddharth, this is the final code that worked for me. The save feature needed to also remove a format and the Formula to search and add the filename to the cells did not work without this edit. I also had to change the sheet to the activeSheet, because it was constantly changing. Here is the code:

修改 Siddharth 提供的代码后，这是对我有用的最终代码。如果没有此编辑，还需要删除格式和公式以搜索并将文件名添加到单元格所需的保存功能不起作用。我还必须将工作表更改为 activeSheet，因为它一直在变化。这是代码：

Sub Naming()

Dim LR As Long, i As Long, lngCol As Long

lngCol = Rows(1).Find("NAME", lookat:=xlWhole).Column 'assumes there will always be a column with "NAME" in row 1

Application.ScreenUpdating = False

LR = Cells(Rows.Count, lngCol).End(xlUp).Row

For i = LR To 1 Step -1

    If Len(Cells(i, lngCol).Value) < 4 Then Rows(i).Delete

Next i

Application.ScreenUpdating = True

' Insert Column after NAME and then rename it NAME+TYPE

Dim ws As Worksheet
Dim lRow As Long, aCol As Long
Dim aCell As Range

Set ws = ActiveSheet 'Need to change to the Active sheet

With ws
    Set aCell = .Rows(1).Find("NAME")

    ' Check if the column with "NAME" is found, it is assumed earlier
    If Not aCell Is Nothing Then
        aCol = aCell.Column
        .Columns(aCol + 1).EntireColumn.Insert
        .Cells(1, aCol + 1).Value = "NAME+TYPE"
        .Activate

    ' Freeze the Top Row

    Rows("1:1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

        ' Get lastrow of Col which has "NAME"
        lRow = .Range(Split(.Cells(, aCol).Address, "$")(1) & .Rows.Count).End(xlUp).Row

        'Save the file and format the filetype
        Dim wkb As Workbook
        Set wkb = ActiveWorkbook 'change to your workbook reference
        wkb.SaveAs Replace(wkb.Name, "#csv.gz", ""), 52 'change "csv.gz" to ".xlsm" if need be

        ' Add the formula to all the cells in 1 go.
        .Range(Split(.Cells(, aCol + 1).Address, "$")(1) & "2:" & _
        Split(.Cells(, aCol + 1).Address, "$")(1) & lRow).Formula = _
        "=LEFT(MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1),5)&RC[-1]"

        .Columns("A:AK").Columns.AutoFit
    Else
        MsgBox "NAME Column Not Found"
    End If
 End With

' Change the Range of the cursor

Range("A1").Select
Application.CutCopyMode = False


End Sub