Question

我有多个包含不同数量工作表的Excel文件。我需要将特定的单元格从每张工作表复制到新工作簿，并复制到以下列-保管库（来自T3），日期（来自G6），取件（来自V10），退款（V13），加载（V11），卸载（V12）），打开（V9），关闭（V14），并在最后一列中指明源文件的名称。

我只是一个无可救药的复制粘贴战士，所以我不是真的很喜欢VBA，但是我发现下面的代码可以正常工作，但仅适用于每个文件中的Sheet1。（例如，如果我将工作表号更改为6，可能会失败，因为并非每个文件都包含6个工作表。）也许有一种方法可以修改此文件以从所有工作表中复制单元格。还是我应该开始一个完全不同的人？

Sub copyfromsheet()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range

Set destsheet = ThisWorkbook.Worksheets(1)
Set RngDest = destsheet.Cells(Rows.Count, 2).End(xlUp) _
                       .Offset(2, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xls*")

'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
    If Fname <> ThisWorkbook.Name Then
        Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
        Set originsheet = wkbkorigin.Worksheets(1)

        With RngDest
            .Cells(1).Value = originsheet.Range("T3").Value 'vault
            .Cells(2).Value = originsheet.Range("G6").Value 'date
            .Cells(3).Value = originsheet.Range("V10").Value 'pickup
            .Cells(4).Value = originsheet.Range("V13").Value 'refund
            .Cells(5).Value = originsheet.Range("V11").Value 'load
            .Cells(6).Value = originsheet.Range("V12").Value 'unload
            .Cells(7).Value = originsheet.Range("V9").Value 'opening
            .Cells(8).Value = originsheet.Range("V14").Value 'closing
            .Cells(9).Value = wkbkorigin.Name 'wbk name H
        End With

        wkbkorigin.Close SaveChanges:=False   'close current file
        Set RngDest = RngDest.Offset(1, 0)
    End If

    Fname = Dir()     'get next file
Loop

End Sub

Answer 1

尝试以下操作：（为打开的工作簿中每个工作表的每个循环添加）

Option Explicit

Sub copyfromsheet()

    Dim wkbkorigin As Workbook, destsheet As Worksheet
    Dim originsheet As Worksheet, RngDest As Range
    Dim Fname$ 

    Set destsheet = ThisWorkbook.Worksheets(1)

    Fname = Dir(ThisWorkbook.Path & "/*.xls*")

    'loop through each file in folder (excluding this one)
    Do While Fname <> "" And Fname <> ThisWorkbook.Name

        If Fname <> ThisWorkbook.Name Then

            Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)

            For Each originsheet In wkbkorigin.Sheets

                Set RngDest = destsheet.Cells(Rows.Count, 2).End(xlUp) _
                       .Offset(2, 0).EntireRow

                With RngDest
                    .Cells(1).Value = originsheet.Range("T3").Value 'vault
                    .Cells(2).Value = originsheet.Range("G6").Value 'date
                    .Cells(3).Value = originsheet.Range("V10").Value 'pickup
                    .Cells(4).Value = originsheet.Range("V13").Value 'refund
                    .Cells(5).Value = originsheet.Range("V11").Value 'load
                    .Cells(6).Value = originsheet.Range("V12").Value 'unload
                    .Cells(7).Value = originsheet.Range("V9").Value 'opening
                    .Cells(8).Value = originsheet.Range("V14").Value 'closing
                    .Cells(9).Value = wkbkorigin.Name 'wbk name H
                End With

            Next

            wkbkorigin.Close SaveChanges:=False   'close current file

        End If

        Fname = Dir()     'get next file
    Loop

End Sub

从多个Excel文件的每张纸中复制相同的单元格

1 个答案: