为每个循环嵌套（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

希望有帮助！