Как использовать заголовки столбцов для выбора различных диапазонов ячеек для заполнения данных из имени файла

@Скотт или Сиддхарт Раут наверное =) — Джонни 11 часов назад

Я бы никогда не рекомендовал это :) В SO полно экспертов, которые могут вам помочь. Почему вы хотите ограничить помощь, которую вы можете получить? ;)

Это то, что вы пытаетесь?

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

После изменения кода, предоставленного Сиддхартом, это окончательный код, который у меня сработал. Функция сохранения также должна была удалить формат, а формула для поиска и добавления имени файла в ячейки не работала без этого редактирования. Мне также пришлось сменить лист на активный лист, потому что он постоянно менялся. Вот код:

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