EXCEL2010 vba 循环打开某些文件夹下的excel文件

Posted 2023-05-09

DirC函数是读取公交车这个文件夹下面所有文件夹的名字，并且存储在目录.xlsx中，这个函数执行是成功。
model函数是循环打开公交车文件夹下每个文件夹里面的目录1.xlsx，打开之后并关闭。运行程序时，发现以下语句是错误的。希望老师能帮我修改以下。
Workbooks.Open ("C:\Documents and Settings\Administrator\桌面\调查数据\编程程序\公交车\" & str1 & "目录1.xlsx")

Sub DirC()
Mypath = "C:\Documents and Settings\Administrator\桌面\调查数据\编程程序\公交车\"
Workbooks.Open ("C:\Documents and Settings\Administrator\桌面\调查数据\编程程序\公交车\目录.xlsx")
MyName = dir(Mypath, vbDirectory) ' 找寻第一项。
i = 1
Do While MyName <> "" ' 开始循环。
' 跳过当前的目录及上层目录。
If MyName <> "." And MyName <> ".." Then
' 使用位比较来确定 MyName 代表一目录。
If (GetAttr(Mypath & MyName) And vbDirectory) = vbDirectory Then
Debug.Print MyName ' 如果它是一个目录，将其名称显示出来。
Workbooks("目录.xlsx").Sheets(1).Cells(i - 2, 1).Value = MyName
End If
End If
MyName = dir ' 查找下一个目录。
i = i + 1
Loop
End Sub

Sub model()
'
' model Macro
'
' 快捷键: Ctrl+p
'
Application.ScreenUpdating = False
Dim str1 As String
i = 1
Workbooks.Open ("C:\Documents and Settings\Administrator\桌面\调查数据\编程程序\公交车\目录.xlsx")
While Workbooks("目录.xlsx").Sheets(1).Cells(i, 1).Value <> ""
str1 = Workbooks("目录.xlsx").Sheets(1).Cells(i, 1).Value
Workbooks.Open ("C:\Documents and Settings\Administrator\桌面\调查数据\编程程序\公交车\" & str1 & "目录1.xlsx")
Workbooks("目录.xlsx").Save
Workbooks("目录.xlsx").Close
i = i + 1
Wend
End Sub

就是遍历文件夹嘛,关键代码如下
在工程-引用里添加 microsoft scripting run time
然后用下面的两个函数递归遍历 就可以了
sub main()
Dim objFSO As Object
Dim objTemplateFolder As Object
Set objFSO = New Scripting.FileSystemObject
Set objTemplateFolder = objFSO.GetFolder(“D:\\”)
getFiles objTemplateFolder
end sub

Sub getFiles(ByRef theFolder As Object)
Dim folder As Object
Dim c As New Scripting.FileSystemObject
‘此处执行你的操作：打开关闭文件夹，取名字等
For Each folder In theFolder.subFolders
getFiles folder ’递归遍历子文件夹
Next
End Sub 参考技术A str1 两边有 “\" 吗？？？？
而且 “目录1.xlsx” 也没有被关闭啊。每次关闭的是 “目录.xlsx" 。
系统是不能打开同名文件的。
关闭的时候可以这样关闭 :
set wb = Workbooks.Open ("C:\Documents and Settings\Administrator\桌面\调查数据\编程程序\公交车\" & str1 & "目录1.xlsx")
wb.Close Savechanges:=True

如何遍历excel VBA宏中的行列

【中文标题】如何遍历excel VBA宏中的行列

【英文标题】：how to loop through rows columns in excel VBA Macro

【发布时间】：2010-11-10 20:38:17

【问题描述】：

您好，我正在尝试创建一个宏，该宏具有一个循环，该循环为每个站复制第 1 列 (VOL) 下的函数和第 2 列 (CAPACITY) 下的另一个函数。这是我目前所拥有的：

Sub TieOut()
    Dim i  As Integer
    Dim j As Integer

    For i = 1 To 3
        For j = 1 To 3
            Worksheets("TieOut").Cells(i, j).Value = "'=INDEX('ZaiNet Data'!$A$1:$H$39038,MATCH('INDEX-MATCH'!Z$7&TEXT('INDEX-MATCH'!$A9,"m/dd/yyyy"),'ZaiNet Data'!$C$1:$C$39038,0), 4)"
        Next j
    Next i

End Sub

我想要的图片如下：你可以看到我已经手动复制并粘贴了我的两个函数到每一列。我只需要一个可以循环的宏。

我想在每个 Station 的 VOL 列中循环的功能是：

=INDEX('ZaiNet Data'!$A$1:$H$39038,MATCH('INDEX-MATCH'!Z$7&TEXT('INDEX-MATCH'!$A438,"M/DD/YYYY"),'ZaiNet Data'!$C$1:$C$39038,0), 4)

我想在每个 Station 的 CAPACITY 列中循环的功能是：

=INDEX('ZaiNet Data'!$A$1:$H$39038,MATCH('INDEX-MATCH'!Z$7&TEXT('INDEX-MATCH'!$A438,"M/DD/YYYY"),'ZaiNet Data'!$C$1:$C$39038,0), 5)

有人可以帮忙吗？谢谢！

更新

****如何使循环自动运行，而无需手动将公式输入前两个单元格并单击宏？ 另外，如何使循环遍历所有列/行？ （横向）****

我添加了两个屏幕截图来说明我的意思。以下是我当前的代码。 谢谢！

    Sub Loop3()
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(0, -1).Select

    Dim i  As Integer
    Dim j As Integer
        With Worksheets("Loop")
            i = 1
            Do Until .Cells(10, i).Value = "blank"
                For j = 1 To 10
                    .Cells(j, i).Formula = "=INDEX('ZAINET DATA'!$A$1:$H$39038,MATCH(Loop!E$7&TEXT(Loop!$A9,""M/D/YYYY""),'ZAINET DATA'!$C$1:$C$39038,0),4)"
                    .Cells(j, i + 1).Formula = "=INDEX('ZAINET DATA'!$A$1:$H$39038,MATCH(Loop!E$7&TEXT(Loop!$A9,""M/D/YYYY""),'ZAINET DATA'!$C$1:$C$39038,0),5)"
                Next j
                i = i + 2
            Loop
    End With

    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(0, -1).Select

End Sub

【问题讨论】：

@Techgirl09，如果你还在关注这个问题，我知道有一种更简单的方法可以做到这一点。 2个问题：公式复制到的范围是否始终相同（即您可以将其设为命名范围）吗？并且您希望它在工作表激活时触发，还是其他什么？

好像是kevin在你截图的时候给你发了邮件，请务必回复他

【参考方案1】：

这是我的建议：

Dim i As integer, j as integer

With Worksheets("TimeOut")
    i = 26
    Do Until .Cells(8, i).Value = ""
        For j = 9 to 100 ' I do not know how many rows you will need it.'
            .Cells(j, i).Formula = "YourVolFormulaHere"
            .Cells(j, i + 1).Formula = "YourCapFormulaHere"
        Next j

        i = i + 2
    Loop
 End With

【讨论】：

谢谢 - 通过单元格复制并粘贴我的公式，但为了做到这一点，我需要手动将公式输入到前两个单元格中，然后单击宏。有没有办法让它完全自动化？例如，如果我的工作表像第三个 STATION 一样完全空白，那么如何自动填充整个公式？

这里只有代码，公式是写在公式属性上的，不是复制的。您无需在前两个单元格中编写公式。

【参考方案2】：

试试这个：

创建一个包含以下内容的宏：

Selection.Copy
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
ActiveCell.Offset(-1, 1).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
ActiveCell.Offset(0, -1).Select

该特定宏会将当前单元格（将光标放在要复制的 VOL 单元格中）向下复制一行，然后也复制 CAP 单元格。

这只是一个循环，因此您可以自动将当前活动单元格（光标所在的位置）的 VOL 和 CAP 复制到下 1 行。

只需将其放在 For 循环语句中即可执行 x 次。 喜欢：

For i = 1 to 100 'Do this 100 times
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(0, -1).Select
Next i

【讨论】：

谢谢！我让它工作了。现在我需要循环运行，直到我的左侧列（日期范围）为空白。我会看看如何做到这一点 - 如果有人可以输入 - 将不胜感激。

【参考方案3】：

这个类似于@Wilhelm 的解决方案。该循环根据通过评估填充的日期列创建的范围自动执行。这是严格根据这里的对话和屏幕截图拍打在一起的。

请注意：这假定标题始终位于同一行（第 8 行）。更改第一行数据（向上/向下移动标题）将导致范围自动化中断，除非您编辑范围块以动态获取标题行。其他假设包括 VOL 和 CAPACITY 公式列标题分别命名为“Vol”和“Cap”。

Sub Loop3()

Dim dtCnt As Long
Dim rng As Range
Dim frmlas() As String

Application.ScreenUpdating = False

'The following code block sets up the formula output range
dtCnt = Sheets("Loop").Range("A1048576").End(xlUp).Row              'lowest date column populated
endHead = Sheets("Loop").Range("XFD8").End(xlToLeft).Column         'right most header populated
Set rng = Sheets("Loop").Range(Cells(9, 2), Cells(dtCnt, endHead))  'assigns range for automation

ReDim frmlas(1)      'array assigned to formula strings
    'VOL column formula
frmlas(0) = "VOL FORMULA"
    'CAPACITY column formula
frmlas(1) = "CAP FORMULA"

For i = 1 To rng.Columns.count
If rng(0, i).Value = "Vol" Then         'checks for volume formula column
    For j = 1 To rng.Rows.count
        rng(j, i).Formula= frmlas(0)    'inserts volume formula
    Next j
ElseIf rng(0, i).Value = "Cap" Then     'checks for capacity formula column
    For j = 1 To rng.Rows.count
        rng(j, i).Formula = frmlas(1)   'inserts capacity formula
    Next j
End If
Next i

Application.ScreenUpdating = True

End Sub

【参考方案4】：

为此，我推荐 Range 对象的 AutoFill method：

rngSource.AutoFill Destination:=rngDest

指定包含要填充的值或公式的源区域，并将目标区域指定为要填充单元格的整个区域。目标范围必须包括源范围。您可以填充也可以向下填充。

它的工作方式与使用鼠标手动“拖动”角落的单元格完全相同； absolute and relative formulas 按预期工作。

这是一个例子：

'Set some example values'
Range("A1").Value = "1"
Range("B1").Formula = "=NOW()"
Range("C1").Formula = "=B1+A1"

'AutoFill the values / formulas to row 20'
Range("A1:C1").AutoFill Destination:=Range("A1:C20")

希望这会有所帮助。