vba 在多个 excel 文件上运行相同的 excel 宏

Question

提问by user1570210

I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ?

我有一个文件夹，我每天收到 1000 多个 excel 文件，它们的格式和结构都相同。我想要做的是每天在所有 100 多个文件上运行一个宏？

Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.

有没有办法自动化这个？所以我可以每天在 1000 多个文件上继续运行相同的宏。

Answer 1

回答by peterm

Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this:

假设您将文件放在相对于主工作簿的“文件”目录中，您的代码可能如下所示：

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

In this example DoWork()is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb(currently opened workbook).

在此示例中DoWork()是您应用于所有文件的宏。确保在宏中进行所有处理始终在wb（当前打开的工作簿）的上下文中。

Disclaimer: all possible error handling skipped for brevity.

免责声明：为简洁起见，跳过了所有可能的错误处理。

Answer 2

回答by Robert Ilbrink

A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks?

问题的一部分可能是我如何在 1000 个文件上运行它？...我是否必须将此宏添加到所有 1000 个工作簿？

One way to do this is to add your macro's centrally to the file PERSONAL.XLSB(sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time.

一种方法是将宏集中添加到文件中PERSONAL.XLSB（有时扩展名可能不同）。每次启动 Excel 时都会在后台加载此文件，并使您的宏随时可用。

Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in.

最初 PERSONAL.XLSB 文件将不存在。要自动创建此文件，只需开始录制“虚拟”宏（使用电子表格左下角的录制按钮）并选择“个人宏工作簿”将其存储。

After recording your macro, you can open the VBA editor with Alt+F11and you will see the PERSONAL.XLSB file with the "dummy" recorded macro.

录制宏后，您可以使用Alt+打开 VBA 编辑器，F11您将看到带有“虚拟”录制宏的 PERSONAL.XLSB 文件。

I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon.

我使用这个文件来存储大量的通用宏，这些宏总是可用的，与我打开的 .xlsx 文件无关。我已将这些宏添加到我自己的菜单功能区中。

One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.

此通用宏文件的一个缺点是，如果您启动多个 Excel 实例，您将收到一条错误消息，指出 Excel 实例 Nr 已在使用 PERSONAL.XLSB 文件。1. 只要你此时不添加新的宏就没有问题。

Answer 3

回答by Jazia Katanani

Thank you very much for this

非常感谢你

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop170206Glidepath\V37\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        BSAQmacro wb

        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub
Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

Answer 4

回答by Bhavik Modi

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\C:\Users098323\Desktop\EXCL\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

While running this code its showing bad file name or number. i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder

运行此代码时，它显示错误的文件名或编号。我已将所有文件存储在 ("\C:\Users\20098323\Desktop\EXCL\") EXCL 文件夹中

Answer 5

回答by Thavachelvan Kesavan

Instead of passing the values to DoWork one can also run the jobs in Processfiles().

除了将值传递给 DoWork 之外，还可以在Processfiles().

Sub ProcessFiles()

    Dim Filename, Pathname As String
    Dim wb1 As Workbook
    Dim wb2 As Workbook

    Dim Sheet As Worksheet
    Dim PasteStart As Range
    Dim Counter As Integer

    Set wb1 = ActiveWorkbook
    Set PasteStart = [RRimport!A1]

    Pathname = ActiveWorkbook.Path & "\For Macro to run\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb2 = Workbooks.Open(Pathname & Filename)
        For Each Sheet In wb2.Sheets
                With Sheet.UsedRange
                .Copy PasteStart
                Set PasteStart = PasteStart.Offset(.Rows.Count)
            End With
        Next Sheet
        wb2.Close
        Filename = Dir()
    Loop
End Sub

Answer 6

回答by user9903

Thanks Peterm!!

谢谢彼得姆！！

Actually, I did my macro using exactly the same code you posted (process_fiels and dowork).

实际上，我使用与您发布的代码完全相同的代码（process_fiels 和 dowork）完成了我的宏。

It worked brilliant!! (before my question)

它工作得很好！！（在我的问题之前）

Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file).

我的 1000 个工作簿中的每一个都有 84 个工作表。我自己的宏（终于起作用了！）将每个工作簿拆分为 85 个不同的文件（每个工作表的原始版本 + 保存为单个文件的简短版本）。

That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out.

这让我在同一个文件夹中有 1000 个文件 + 1000x85，这真的很难理清。

What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc...

我真正需要的是 Process_Files 取第一个文件，创建一个名为第一个文件的文件夹，将第一个文件移动到具有 ist 名称的文件夹，然后运行我的宏（在以第一个文件命名的文件夹中）新创建的文件夹...），返回取第二个文件，创建一个名为第二个文件的文件夹，将第二个文件移动到名为ist的文件夹，然后运行我的宏（在以第二个文件命名的文件夹中）新创建的文件夹中的文件...）等...

At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does.

最后，我应该将所有文件移动到与文件同名的文件夹中，原始 \Files\ 文件夹的内容将是具有原始文件名称的 1000 个文件夹，包含原始文件 + 84 个文件我自己的宏已经这样做了。

Maybe it is easier with the code:

也许使用代码更容易：

Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook

Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""

(Here, it should read the file name, create a folder with the file name, move the file into this newly created folder)

（这里，它应该读取文件名，用文件名创建一个文件夹，将文件移动到这个新创建的文件夹中）

    Set wb = Workbooks.Open(Pathname & Filename)  <- open file, just as is.
    DoWork wb   <- do my macro,just as is
    wb.Close SaveChanges:=False      <- not save, to keep the original file

(go back to the original \Files\ folder)

（回到原来的 \Files\ 文件夹）

    Filename = Dir()   <-   Next file, just as is
Loop

End Sub

结束子

Sub DoWork(wb As Workbook) With wb MyMacro End With End Sub

Many thanks, this site is great!

非常感谢，这个网站很棒！

__________________edit, the macro now works _________________________

__________________编辑，该宏现在可以使用 _________________________

As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer.

如您所见，我不是 VBA 专家，但宏终于可以工作了。代码一点都不整洁，我不是软件程序员。

Here it is, it might help some one some day.

就是这样，有一天它可能会对某些人有所帮助。

Sub ProcessFiles_All() Dim Filename, Pathname, NewPath, FileSource, FileDestination As String Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.csv")

 Do While Filename <> ""

     NewPath = Pathname & Left(Filename, 34) & "\"

 On Error Resume Next
     MkDir (NewPath)
 On Error GoTo 0

 Set wb = Workbooks.Open(Pathname & Filename)

    DoWorkPlease wb   '  <------------   It is important to say please!!

On Error Resume Next wb.Close SaveChanges:=False if Err.Number <> 0 then ‘Error handler needed here End if

On Error Resume Next wb.Close SaveChanges:=False if Err.Number <> 0 then 'Error handler needed here End if

    Filename = Dir()

 Loop

End Sub

结束子

Sub DoWorkPlease(wb As Workbook) With wb

‘ Since my application has over 1800 cells for each column and it is time consuming ‘ I use a “testing mode” were I only play with 18 values.

' 因为我的应用程序每列有超过 1800 个单元格，这很耗时 ' 我使用“测试模式”，因为我只玩了 18 个值。

 Dim TestingMode As Integer
 Dim ThisRange(1 To 4) As Variant

 TestingMode = 0

If TestingMode = 1 Then
   ThisRange(1) = "B2:CG18"
   ThisRange(2) = "CT2:CT18"
   ThisRange(3) = "CH2:CN18"
   ThisRange(4) = "CN2:CS18"
   Rows("19:18201").Select
   Selection.Delete Shift:=xlUp
End If

If TestingMode = 0 Then
   ThisRange(1) = "B2:CG18201"
   ThisRange(2) = "CT2:CT18201"
   ThisRange(3) = "CH2:CN18201"
   ThisRange(4) = "CN2:CS18201"
End If

‘ speed up the macro, turn off updating and alerts
Application.ScreenUpdating = False Application.DisplayAlerts = False

' 加速宏，关闭更新和警报
Application.ScreenUpdating = False Application.DisplayAlerts = False

‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually.

'这是我的代码，它从数字中操作单元格值（传感器读取的值需要“转换”为现实世界的值。实际上代码不在此处。

‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way.

'然后我将整个事情复制成数字，不再有公式，这样更容易工作。

'_____________________________________ 'Get just values - no more formulas

'_____________________________________ '只获取值 - 没有更多的公式

 Sheets.Add After:=Sheets(Sheets.Count)
 Sheets("Sheet1").Select
 Columns("A:CT").Select
 Selection.Copy
 Sheets("Sheet2").Select
 Columns("A:A").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False
 Application.CutCopyMode = False
 Selection.NumberFormat = "0"
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With

‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\

' 然后我将这个新工作簿保存到一个有自己名字的文件夹中（在文件夹 \FILES\

'_____________________________________ 'Save the work under its own folder

'_____________________________________ '将作品保存在自己的文件夹下

Dim CleanName, CleanPath, CleanNewName As Variant CleanPath = ActiveWorkbook.Path CleanName = ActiveWorkbook.Name CleanName = Left(CleanName, 34) ‘I take out the extension CleanPath = CleanPath + "\" + CleanName CleanNewName = CleanPath + "\" + CleanName CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now.

Dim CleanName, CleanPath, CleanNewName As Variant CleanPath = ActiveWorkbook.Path CleanName = ActiveWorkbook.Name CleanName = Left(CleanName, 34) '我取出扩展 CleanPath = CleanPath + "\" + CleanName CleanNewName = CleanPath + "\" + CleanName CleanNewName = CleanNewName + "_clean.csv" ' 并且我现在添加“clean”以具有不同的名称。

On Error Resume Next ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False

‘If there is an error I create an empty folder with the name of the file to know which file needs rework.

'如果有错误，我会用文件名创建一个空文件夹，以了解哪个文件需要返工。

If Err.Number <> 0 Then
    MkDir (CleanPath + "_error_" + CleanName)
End If

'Resume Next

'继续下一步

ActiveSheet.Move _ After:=ActiveWorkbook.Sheets(1)

‘ Then I split the workbook into individual files with the data I need for individual sensors.

' 然后我将工作簿拆分为单个文件，其中包含单个传感器所需的数据。

‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort.

' 这是我需要的每个文件的单独范围。由于我有 1000 多个文件，因此值得付出努力。

'_______________ the Split!!______________________________

'_______________ 分裂！！______________________________

Dim Col(1 To 98) As Variant Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT" Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT" Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT" Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT" Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT" Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT" Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT" Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT" Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT" Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT" Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT" Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT" Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT" Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT" Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT" Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT" Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT" Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT" Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT" Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT" Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT" Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT" Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT" Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT" Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT" Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT" Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT" Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT" Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT" Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT" Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT" Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT" Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT" Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT" Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT" Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT" Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT" Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT" Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT" Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT" Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT" Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT" Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT" Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT" Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT" Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT" Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT" Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT" Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT" Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT" Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT" Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT" Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT" Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT" Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT" Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT" Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT" Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT" Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT" Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT" Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT" Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT" Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT" Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT" Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT" Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT" Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT" Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT" Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT" Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT" Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT" Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT" Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT" Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT" Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT" Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT" Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT" Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT" Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT" Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT" Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT" Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT" Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT" Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT" ‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84

Dim Col(1 to 98) As Variant Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT" Col(2) = "A:A,C:C,CH :CH,CN:CN,CT:CT" Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT" Col(4) = "A:A,E:E ,CH:CH,CN:CN,CT:CT" Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT" Col(6) = "A:A,G :G,CH:CH,CN:CN,CT:CT" Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT" Col(8) = "A:A ,I:I,CH:CH,CN:CN,CT:CT" Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT" Col(10) = "A :A,K:K,CH:CH,CN:CN,CT:CT" Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT" Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT" Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT" Col(14) ) = "A:A,O:O,CH:CH,CN:CN,CT:CT" Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT" Col (16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT" Col(18) = "A:A,S:S,CI:CI,CO:CO,CT: CT" Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT" Col(20) = "A:A,U:U,CI:CI,CO:CO, CT:CT" Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT" Col(22) = "A:A,W:W,CI:CI,CO: CO,CT:CT" Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT" Col(24) = "A:A,Y:Y,CI:CI, CO:CO,CT:CT" Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT" Col(26) = "A:A,AA:AA,CI: CI,CO:CO,CT:CT" Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT" Col(28) = "A:A,AC:AC, CI:CI,CO:CO,CT:CT" Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT" Col(30) = "A:A,AE: AE,CJ:CJ,CP:CP,CT:CT" Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT" Col(32) = "A:A, AG:AG,CJ:CJ,CP:CP,CT:CT"Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT" Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT: CT" Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT" Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP, CT:CT" Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT" Col(38) = "A:A,AM:AM,CJ:CJ,CP: CP,CT:CT" Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT" Col(40) = "A:A,AO:AO,CJ:CJ, CP:CP,CT:CT" Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT" Col(42) = "A:A,AQ:AQ,CJ: CJ,CP:CP,CT:CT" Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT" Col(44) = "A:A,AS:AS, CK:CK,CQ:CQ,CT:CT" Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT" Col(46) = "A:A,AU: AU,CK:CK,CQ:CQ,CT:CT" Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT" Col(48) = "A:A, AW:AW,CK:CK,CQ:CQ,CT:CT" Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT" Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ, CT:CT" Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT" Col(52) = "A:A,BA:BA,CK:CK,CQ: CQ,CT:CT" Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT" Col(54) = "A:A,BC:BC,CK:CK, CQ:CQ,CT:CT" Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT" Col(56) = "A:A,BE:BE,CK: CK,CQ:CQ,CT:CT" Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT" Col(58) = "A:A,BG:BG, CL:CL,CR:CR,CT:CT" Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT" Col(60) = "A:A,BI: BI,CL:CL,CR:CR,CT:CT" Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT" Col(62) = "A:A, BK:BK,CL:CL,CR:CR,CT:CT" Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT" Col(64) = "A: A,BM:BM,CL:CL,CR:CR,CT:CT" Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT" Col(66) = "A:A,BO:BO,CL:CL, CR:CR,CT:CT" Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT" Col(68) = "A:A,BQ:BQ,CL: CL,CR:CR,CT:CT" Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT" Col(70) = "A:A,BS:BS, CL:CL,CR:CR,CT:CT" Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT" Col(72) = "A:A,BU: BU,CM:CM,CS:CS,CT:CT" Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT" Col(74) = "A:A, BW:BW,CM:CM,CS:CS,CT:CT" Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT" Col(76) = "A: A,BY:BY,CM:CM,CS:CS,CT:CT" Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT" Col(78) = " A:A,CA:CA,CM:CM,CS:CS,CT:CT" Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT" Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT" Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT" Col(82) = "A:A,CE:CE, CM:CM,CS:CS,CT:CT" Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT" Col(84) = "A:A,CG: CG,CM:CM,CS:CS,CT:CT" ' 我想拆分 84 个新文件，所以为了测试我只使用 1 个，而对于真实的我使用 84 个

Dim CounterMode As Integer

Dim CounterMode 作为整数

If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84

如果 TestingMode = 1 然后 CounterMode = 1 否则 CounterMode = 84

For i = 1 To CounterMode

‘ this code takes the columns need, and paste it into a new workbook.

' 此代码获取所需的列，并将其粘贴到新工作簿中。

 Sheets("Sheet1").Select
 Cells.Select
 Selection.ClearContents
 Range("A1").Activate
 Sheets(2).Select
 Range(Col(i)).Select
 Selection.Copy
 Sheets("Sheet1").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With
 Columns("A:E").EntireColumn.AutoFit

‘ Save the individual file

' 保存单个文件

'_____________save the work________________

Dim ThePath, TheName, TheSwitch As String ThePath = ActiveWorkbook.Path + “\” TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name ThePath = ThePath + TheName TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name. TheName = ThePath + "_" + TheSwitch + ".xls"

Dim ThePath, TheName, TheSwitch As String ThePath = ActiveWorkbook.Path + “\” TheName = Left(ActiveWorkbook.Name, 34) ' 从名称中取出扩展名 ThePath = ThePath + TheName TheSwitch = Cells(3, 2) ' 在单元格(3,2) 我有个人名字的名字，所以我添加到文件名中。TheName = ThePath + "_" + TheSwitch + ".xls"

Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy

Dim SheetName As Variant

‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test. ‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the ‘ original name

' 我将 Sheets(1) 命名为 Sheet1，因为原始表具有测试的名称和日期。' 我这样做是为了在所有文件上使用相同的名称以进行绘图，然后我用'原始名称重命名工作表

SheetName = ActiveSheet.Name ActiveWorkbook.Sheets(1).Name = "Sheet1"

‘ here is the plot

'这是情节

Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers

ActiveWorkbook.Sheets(1).Name = SheetName

‘save On Error Resume Next ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False

'save On Error Resume Next ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False

If Err.Number <> 0 Then
    MkDir (ThePath + "_error_" + TheName)
End If

ActiveWorkbook.Close

Next i '____________________That was the Split__________________________________ ' Turn on screenupdating: Application.ScreenUpdating = True Application.DisplayAlerts = True Range("A1").Select

接下来我 '____________________That was the Split__________________________________' 打开屏幕更新：Application.ScreenUpdating = True Application.DisplayAlerts = True Range("A1").Select

 End With

End Sub

结束子

vba 在多个 excel 文件上运行相同的 excel 宏

提问by user1570210

回答by peterm

回答by Robert Ilbrink

回答by Jazia Katanani

回答by Bhavik Modi

回答by Thavachelvan Kesavan

回答by user9903

相关推荐

最近更新

标签

vba 在多个 excel 文件上运行相同的 excel 宏

提问by user1570210

回答by peterm

回答by Robert Ilbrink

回答by Jazia Katanani

回答by Bhavik Modi

回答by Thavachelvan Kesavan

回答by user9903

相关推荐

vba 如何使用VBA在Excel中对范围内的每一行求和

VBA 有一个子运行另一个子

使用 VBA 进行颜色填充，以单元格值为条件

vba 将包含宏的工作簿复制到没有宏的工作簿

相关推荐

最近更新

标签