0

これは、この投稿から生じる別の質問です。Excelファイルのファイル名を使用してセルの列を変更するにはどうすればよいですか。

前回の投稿のコードで、特定のセル（J2、K2）を参照していることに気付きました。ただし、コードを使用すると、列が変更されたときにエラーが発生しました。そこで、特定のセルを参照する代わりに、ヘッダー列の名前を使用して2番目の列にデータを入力するように、以下のコードを変更する方法を探しています。本当に調整が必要な行はmyRng行だけだと思いますが、参照しようとしているすべてのコードを提供します。

他の投稿を読んでいない場合は、問題について説明します。「名前」列とファイル名に基づいて2番目の列（名前+タイプ）に入力しようとしています。コードでKまたはJ行を参照しているときは、すべてが正常に機能していましたが、別のファイルをロードして列の位置が変更されると、すべてが台無しになります。

2番目の列（名前+タイプ）を1番目の列（名前）とまったく同じ数または行にする必要があるため、範囲（ "K2：K"＆lastCell）式を使用しています。

これを行う方法はありますか？

現在試行されている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

最初のドラフト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
4

2 に答える 2

1

@Scott または Siddharth Rout おそらく =) – ジョニー 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
于 2012-06-28T08:27:12.423 に答える
0

Siddharth によって提供されたコードを変更した後、これは私のために働いた最終的なコードです。フォーマットを削除するために必要な保存機能と、ファイル名を検索してセルに追加するための数式は、この編集なしでは機能しませんでした。また、シートは常に変化していたため、アクティブシートに変更する必要がありました。コードは次のとおりです。

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
于 2012-06-28T14:09:13.427 に答える