Question

我对VBA很新，所以我提前道歉。我已经参与了一些复杂的操作，我非常感谢一些帮助或输入。

有了这个宏，我想：

从特定文件夹中复制特定范围（2列宽）。
将范围值（以及格式化，如果可能）粘贴到已打开的主工作簿的列中，从B7开始，并为每个新文档移动2列以使粘贴的数据不重叠。
复制/粘贴完成后关闭文件

截至目前，我收到了

运行时错误9：下标超出范围

的

Workbooks("RF_Summary_Template").Worksheets("Summary").Select

我知道这是我遇到的最少的问题。

以下是我的代码：

Sub compile()

    Dim SummaryFile As String, SummarySheet As String, summaryColumn As Long
    Dim GetDir As String, Path As String
    Dim dataFile As String, dataSheet As String, LastDataRow As Long
    Dim i As Integer, FirstDataRow As Long


    '********************************

    RF_Summary_Template = ActiveWorkbook.Name  'summarybook
    Summary = ActiveSheet.Name     'summarysheet

    summaryColumn = Workbooks(RF_Summary_Template).Sheets(Summary).Cells(Columns.Count, 1).End(xlToLeft).Column + 1
    CreateObject("WScript.Shell").Popup "First, browse to the correct directory, select ANY file in the directory, and click Open.", 2, "Select Install Base File"

    GetDir = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")

    If GetDir <> "False" Then
        Path = CurDir & "\"
    Else
        MsgBox "Directory not selected"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    dataFile = Dir(Path & "*.xls")

    While dataFile <> ""
        Workbooks.Open (dataFile)
        Worksheets("Dashboard").Activate
        ActiveSheet.Range("AY17:AZ35").Copy

        Workbooks("RF_Summary_Template").Worksheets("Summary").Select
        Range("B8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        Workbooks(dataFile).Close
        summaryColumn = summaryColumn + 2

        dataFile = Dir()
    Wend

    Workbooks(RF_Summary_Template).Save
    Application.ScreenUpdating = True

End Sub

万分感谢

Answer 1

我希望这会有所帮助。运行程序＆＃34; CopyDataBetweenWorkBooks＆＃34;

Sub CopyDataBetweenWorkbooks()

    Dim wbSource As Workbook
    Dim shTarget As Worksheet
    Dim shSource As Worksheet
    Dim strFilePath As String
    Dim strPath As String

    ' Initialize some variables and
    ' get the folder path that has the files
    Set shTarget = ThisWorkbook.Sheets("Summary")
    strPath = GetPath

    ' Make sure a folder was picked.
    If Not strPath = vbNullString Then

        ' Get all the files from the folder
        strfile = Dir$(strPath & "*.xls", vbNormal)

        Do While Not strfile = vbNullString

            ' Open the file and get the source sheet
            Set wbSource = Workbooks.Open(strPath & strfile)
            Set shSource = wbSource.Sheets("Dashboard")


            'Copy the data
            Call CopyData(shSource, shTarget)

            'Close the workbook and move to the next file.
            wbSource.Close False
            strfile = Dir$()
        Loop
    End If

End Sub

' Procedure to copy the data.
Sub CopyData(ByRef shSource As Worksheet, shTarget As Worksheet)

    Const strRANGE_ADDRESS As String = "AY17:AZ35"

    Dim lCol As Long

    'Determine the last column.
    lCol = shTarget.Cells(8, shTarget.Columns.Count).End(xlToLeft).Column + 1

    'Copy the data.
    shSource.Range(strRANGE_ADDRESS).Copy
    shTarget.Cells(8, lCol).PasteSpecial xlPasteValuesAndNumberFormats

    ' Reset the clipboard.
    Application.CutCopyMode = xlCopy

End Sub


' Fucntion to get the folder path
Function GetPath() As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Select a folder"
        .Title = "Folder Picker"
        .AllowMultiSelect = False

        'Get the folder if the user does not hot cancel
        If .Show Then GetPath = .SelectedItems(1) & "\"

    End With

End Function

我希望这会有所帮助：）

Answer 2

借助此代码，您可以复制所有工作簿和工作表数据进入一本工作簿

Sub copydata()

Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range

Set fso = New Scripting.FileSystemObject

Set wb = ThisWorkbook

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show

oldfolder = fd.SelectedItems(1)

Set myfolder = fso.GetFolder(oldfolder)

'Application.ScreenUpdating = False

Application.EnableEvents = False
 

For Each subfolder In myfolder.SubFolders

    For Each fill In subfolder.Files
            If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
            'fill.Range("A1:Z100").Copy
            Set wb2 = Application.Workbooks.Open(fill,0 , True)
            wb2.Activate
            For loopcount = 1 To wb2.Worksheets.Count
            wb2.Activate
            Worksheets(loopcount).Activate
            Range("A1:Z300").Copy          'Replace your range
            wb.Activate
            Sheet1.Activate
            Set rr = Range("A:A").Find("", Range("A1"))
            rr.Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Next loopcount
            wb2.Close False
            End If
            
        Application.CutCopyMode = False
        
        Debug.Print fill.Name
    
    Next fill
    
Next subfolder
        MsgBox "Done"

    For Each fill In myfolder.Files
        Application.DisplayAlerts = False
    
         If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
            'fill.Range("A1:Z100").Copy
            Set wb2 = Application.Workbooks.Open(fill, 0, True)
            wb2.Activate
            
            For loopcount = 1 To wb2.Worksheets.Count
        
            wb2.Activate
            Worksheets(loopcount).Activate
            
            Range("A:Z").EntireColumn.Hidden = False
            
            Range("A1:Z1").AutoFilter
            Range("A1:Z300").Copy
            wb.Activate
            
            Sheet1.Activate
            Set rr = Range("A:A").Find("", Range("A1"))
            rr.Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Next loopcount
            wb2.Close False
            End If
            
        Application.CutCopyMode = False
        
        Debug.Print fill.Name
        
    Next fill
Application.EnableEvents = True

End Sub

Answer 3

const { Cluster } = require('puppeteer-cluster');

const videos = [];

(async () => {
    // Setup a cluster with 4 browsers in parallel
    const cluster = await Cluster.launch({
        concurrency: Cluster.CONCURRENCY_BROWSER,
        maxConcurrency: 4,
    });

    // Define your task to be executed
    await cluster.task(async ({ page, data: url }) => {
        await page.goto(url);
        await page.waitForSelector('.music-info');

        var vidInfo = await page.evaluate(/* ... */);
        videos.push(vidInfo);
    });

    // Queue your URLs
    for(var i = 0; i < profile.videoLinks.length; i++){
        cluster.queue(profile.videoLinks[i].video);
    }

    // Wait for the cluster to finish and close it
    await cluster.idle();
    await cluster.close();
})();

Answer 4

Sub final_consolidate()

f_path = "tree"

strFileToOpenIB = Application.GetOpenFilename(Title:="Please select the Consolidated file for Bangladesh", FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Set wbIB = Workbooks.Open(strFileToOpenIB)
wbIB.Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
wbIB.Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Copy After:=Workbooks("Book1").Sheets(1)
wbIB.Activate
ActiveWorkbook.Close
Windows("Book1").Activate

strFileToOpenIB = Application.GetOpenFilename(Title:="Please select the Consolidated file for SriLanka", FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Set wbIB = Workbooks.Open(strFileToOpenIB)
wbIB.Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Workbooks("Book1").Sheets(2)
wbIB.Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Copy After:=Workbooks("Book1").Sheets(3)
wbIB.Activate
ActiveWorkbook.Close
Windows("Book1").Activate

ActiveWorkbook.SaveAs Filename:=f_path, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


End Sub

复制文件夹中所有文件的范围并粘贴到主工作簿

4 个答案: