Question

我将从多个工作簿中的大量数据生成一些图表。所有工作簿中的数据格式完全相同，并且位于同一级别的所有文件夹中。我将把数据的部分（范围）带到一个最终的工作簿中，我将从中生成图表。

这让我觉得这种事情对于VBA自动化已经成熟。唯一的问题，我是新手。我已经尝试编写伪代码，然后用我认为正确的VBA替换它。我环顾四周寻找示例，并尝试了Excel帮助文件，但我在某处遗漏了一些重要的步骤......以及一些基本步骤。

很多事情似乎都是错的（......至少在周末之前你会有一些微笑的东西）。如果有人能指出我的大脑放弃了我的位置，我将非常感激。

另外，如何在同一行的B列中添加范围来自的文件的名称？这对我来说真的有帮助，但我找不到一个例子怎么做。

Sub CopySourceValuesToDestination()

Dim DestPath As String
Dim SourcePath As String
Dim Folder As Variant
Dim Folders As Variant
Dim FileInFolder As Variant
Dim Range1 As Range
Dim Range2 As Range
Dim DesitnationPaste1 As Variant
Dim DesitnationPaste2 As Variant


Folder = Array("ABC", "DEF", "GHI", "JKL")
FileInFolder = Array("ABCFile", "DEFFile", "GHIFile", "JKLFile")

''My final Excel file sits in the parent folder of the source files folders
DestPath = "S:\Common\XYZ\Michael S\Macrotest\"

''Each file has it's own folder, and there are many specific files in each
SourcePath = "S:\Common\XYZ\Michael S\Macrotest\ + Folder"

''Always the same in each of my source files
Range1 = Cells("C4:C8") 
Range2 = Cells("C17:D21") 

''Below I 'm trying to paste Range1 into Column C directly under the last used cell
DestinationPaste1 = Range("C5000").End(xlUp).Offset(1, 0)

 ''Below I 'm trying to paste Range2 into Column D directly under the last used cell
DestinationPaste2 = Range("D5000").End(xlUp).Offset(1, 0)

''Trying to make it loop through the folder and the_
''files...but this is just a guess
For Each Folder In Folders 
''Again a guess
F = 0 

''The rest of the process would open a source file copy_
''Range1 and then opening the Destination file and pasting_
''it in the Row 1 of Column C. Hopefully it then goes back_
''to the open source file copies Range2 and pastes it the_
''next Row down in Column C

    Workbooks.Open FileName:=SourcePath + FileName + "Source.xls"

        Workbook.Sheet(Sheet2).Range1.Copy

    Workbook.Open FileName:=DestPath + "Destination.xls"

        Workbook.Sheet(Sheet1).DestinationPaste.Select
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
            Operation:= xlNone, SkipBlanks:=False, Transpose:=True

    Windows(SourcePath + FileName + "Source.xls").Activate

        Workbook.Sheet(Sheet2).Range2.Copy

    Workbook.Open FileName:=DestPath + "Destination.xls"

        Workbook.Sheet(Sheet1).DestinationPaste.Select
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=True

  Windows(SourcePath + FileName + "Source.xls").Activate
    ActiveWorkbook.Close
F = F + 1
Next

End Sub

该过程的结果如下图所示 - 但没有颜色或附加“_b”：

Final Data Output http://i51.tinypic.com/14sm6ac.jpg

再次感谢您给我的任何帮助。

迈克尔。

Answer 1

我不知道这是不是你想要的，但我认为这会让你更接近，并为你提供一些如何进行的线索。我们可以对其进行编辑以使其正确。

Sub CopySourceValuesToDestination()

    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sDestPath As String
    Dim sSourcePath As String
    Dim shDest As Worksheet
    Dim rDest As Range
    Dim vaFolder As Variant
    Dim vaFiles As Variant
    Dim i As Long

    'array of folder names under sDestPath
    vaFolder = Array("ABC", "DEF", "GHI", "JKL")

    'array of file names under the respective folders in vaFolder
    vaFiles = Array("ABCFile.xls", "DEFFile.xls", "GHIFile.xls", "JKLFile.xls")

    sDestPath = "S:\Common\XYZ\Michael S\Macrotest\"
    sSourcePath = "S:\Common\XYZ\Michael S\Macrotest\"

    'Open the destination workbook at put the destination sheet in a variable
    Set wbDest = Workbooks.Open(sDestPath & "Destination.xls")
    Set shDest = wbDest.Sheets(1)

    'loop through the folders
    For i = LBound(vaFolder) To UBound(vaFolder)
        'open the source
        Set wbSource = Workbooks.Open(sSourcePath & vaFolder(i) & "\" & vaFiles(i))

        'find the next cell in col C
        Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
        'write the values from source into destination
        rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C4:C8").Value

        'repeat for next source range
        Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
        rDest.Resize(5, 2).Value = wbSource.Sheets(1).Range("C17:D21").Value

        wbSource.Close False
    Next i

End Sub

Excel VBA：自动将不同工作簿中的范围复制到最终目标工作表中？

1 个答案: