為每個循環嵌套（Excel VBA）

Question

我創建了一個 xlsm 文件，以便使用 excel 打開 txt 文件（D 列）並更改工作表名稱，如 C 列中所示。 用戶將使用 InputBox 選擇 C 和 D 列所需的行。 當我按下按鈕時，我可以毫無問題地選擇行，並在單獨的 excel 文件上打開 txt 文件。 但是，3 個打開的 txt 文件的所有工作表的名稱是 C “NeighON_WSMON”列上的最后一個。 但是，我希望 D4 列的文件具有 C4 列的工作表名稱，依此類推。 我怎樣才能做到這一點？ 最后，如何將 excel 文件保存到一個 excel 文件中？ 非常感謝您對此的支持。

Private Sub CommandButton1_Click()

Dim myPath As String
Dim rng As Range
Dim cell As Range
Dim rngName As Range
Dim cellName As Range

myPath = Application.ActiveWorkbook.Path

'Show inputbox to user and  prompt for a cell range
Set rng = Application.InputBox(Prompt:="Please select the cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, Type:=8)

'Show inputbox to user and  prompt for a cell range
Set rngName = Application.InputBox(Prompt:="Please select the cell range:", _
Title:="Name sheets", _
Default:=Selection.Address, Type:=8)

'Iterate through cells in selected range
For Each cell In rng
    'Check if cell is not empty
    If cell <> "" Then        
        For Each cellName In rngName
            If cellName <> "" Then
            Set TxtFiles = Workbooks.Open(myPath & "\" & cell & ".txt")
            TxtFiles.Sheets(1).Name = cellName
            End If
        Next cellName
        'TxtFiles.Sheets(1).Name = "Tarrak"
        'TxtFiles.Sheets(1).Copy
        'NewBook.Worksheets.Add.Name = cell
    End If
'Continue with next cell in cell range
Next cell
    
End Sub

Answer 1

簡短的回答：

您對單元格的迭代次數也比您的意思更頻繁，並且在您打算進行 3 次的地方進行了 9 個workbooks.open()調用。也就是說，您按以下順序迭代cell和cellName以產生以下影響。

Cell  CellName    Impact
-----+-----------+-----------------------------
[C3]  [D3]        Open D3, name as C3
[C3]  [D4]        Open D4, name as C3
[C3]  [D5]        Open D5, name as C3
[C4]  [D3]        Activate D3, re-name as C4
[C4]  [D4]        Activate D4, re-name as C4
[C4]  [D5]        Activate D5, re-name as C4
[C5]  [D3]        Activate D3, re-name as C5
[C5]  [D4]        Activate D4, re-name as C5
[C5]  [D5]        Activate D5, re-name as C5

要更正此問題，您應該將其轉換為單個 for 循環； 這將要求您確保rng和rngName中有相同數量的值。

---

更長的答案

我建議對該項目進行一些更改。 首先，我建議您將Microsoft Scripting Runtime引用添加到您的項目中，這樣您就可以輕松地利用FileSystemObject類型 - 這對於您需要處理文件 I/O 的任何時候都非常棒。

我個人偏好使用它是添加行

Global fso As New Scripting.FileSystemObject

到文件的頭部。 無需初始化 object，它可以從所有范圍訪問。

然后，我建議您將打開並重命名 txt 文件表的操作中斷為它自己的 function。

這個 function 的最簡單版本看起來像

Private Function OpenTXTasWB(ByVal txtName As String, ByVal path As String, _
                             ByVal sheetName As String) As Excel.Workbook
            
    Dim wb As Excel.Workbook
    Set wb = Application.Workbooks.Open(fso.BuildPath(path, txtName))
    Let wb.Worksheets(1).Name = sheetName
    Set OpenTXTasWB = wb

End Function

但是您可以輕松地對其進行修改以使其具有更好的錯誤處理能力，或者允許可選的 arguments。 這樣的修改版本看起來像

Private Function OpenTXTasWB(ByVal txtName As String, _
                    Optional ByVal path As Variant, _
                    Optional ByVal sheetName As Variant) _
            As Excel.Workbook
    
    Dim wb      As Excel.Workbook, _
        bOldDA  As Boolean
    
    '' check for missing input and assign defaults (optional, but preferred)
    If IsMissing(path) Then Let path = Application.ThisWorkbook.path
    'If IsMissing(sheetName) Then Let sheetName = "default-value"       '' If you want a defualt name
    
    
    '' Error handling for bad inputs (optional, but preferred)

    ''  check for bad path var
    If Not TypeName(path) = "String" Then
        Call Err.Raise(Number:=13, Description:="function `OpenTXTasWB(txtName,[path],[sheetname])` expected `path` to " & _
                                                "be of type `string`, however type `" & TypeName(path) & "` was supplied.")
    ElseIf Not fso.FolderExists(path) Then
        Call Err.Raise(Number:=76, Description:="function `OpenTXTasWB(txtName,[path],[sheetname])` expected `path` to " & _
                                                "a valid directory, however, it was not found")
    End If
    
    ''  check for bad sheetname var
    If Not TypeName(sheetName) = "String" And Not IsMissing(sheetName) Then
        Call Err.Raise(Number:=13, Description:="function `OpenTXTasWB(txtName,[path],[sheetname])` expected `sheetname` to " & _
                                                "be of type `string`, however type `" & TypeName(sheetName) & "` was supplied.")
    End If
    
    '' check for a non-existant file
tryWithExt:
    If Not fso.FileExists(fso.BuildPath(path, txtName)) Then
        If Not InStr(1, StrReverse(txtName), ".") > 1 Then
            Let txtName = txtName & ".txt"
            GoTo tryWithExt
        End If
        Call Err.Raise(Number:=53, Description:="function `OpenTXTasWB(txtName,[path],[sheetname])` expected to find a flle " & _
                                                "at `" & fso.BuildPath(path, txtName) & "`, but none was found.")
    End If
    
    '' open the file as wb
    Set wb = Application.Workbooks.Open(fso.BuildPath(path, txtName))
    
    '' set the name, iff a name was supplied
    If Not IsMissing(sheetName) Then Let wb.Worksheets(1).Name = sheetName
    
    '' output the wb
    Set OpenTXTasWB = wb

End Function

但是您是否選擇實現功能類型完全取決於您。

無論哪種方式，您選擇設置開放 function，這將大大簡化您演示的主要部分。 如果您想單獨處理工作簿，這看起來像

Public Sub demo()

    Dim rSheets As Excel.Range, _
        rSheet  As Excel.Range
    
    Set rSheets = Application.InputBox( _
            Prompt:="Please select the cell range:", _
            Title:="Create sheets", _
            Default:=Selection.Address, Type:=8)
    
    For Each rSheet In rSheets
        
        '' file to open is rsheet.offset(0,1)
        '' sheet name is rsheet.Offset(0,0)
        
        Set wb = OpenTXTasWB(txtName:=rSheet.Offset(0, 1), sheetName:=rSheet.Offset(0, 1))
            
    Next rSheet
    
End Sub

或者，如果您想保留工作簿以備后用，它看起來更像是下面的內容。

Public Sub demo2()

    Dim rSheets As Excel.Range, _
        rSheet  As Excel.Range, _
        wbs()   As Excel.Workbook, _
        iter    As Long
    
    Set rSheets = Application.InputBox( _
            Prompt:="Please select the cell range:", _
            Title:="Create sheets", _
            Default:=Selection.Address, Type:=8)
    
    ReDim wb(1 To rSheets.Cells.Count)
    
    For iter = 1 To rSheets.Cells.Count Step 1
        Set rSheet = rSheets.Item(iter)

        Set wbs(iter) = OpenTXTasWB(txtName:=rSheet.Offset(0, 1), sheetName:=rSheet.Offset(0, 1))
        
    Next rSheet        

End Sub

希望有幫助！