将范围从不同的工作簿复制到一个最终目标表中 [英] Copying ranges from different workbooks into one final destination sheet
问题描述
我将根据多个工作簿中的大量数据生成一些图形.数据在所有工作簿中的格式完全相同,并且都位于同一级别的文件夹中.我将把数据的一部分(范围)放入一本最终的工作簿中,从中生成图表.
I'm going to be generating some graphs from a lot of data located in multiple workbooks. The data is formatted exactly the same in all workbooks and reside in folders all at the same level. I'm going to be bringing parts (ranges) of the data into one final workbook where I'll generate my graphs from.
我到处寻找示例,并尝试使用Excel帮助文件.
I've looked around for examples, and tried Excel help files.
很多事情似乎是错误的.
Lots of things seem to be wrong.
此外,如何在同一行的B列中添加范围来自的文件的名称?
Also, how do you add the name of the file that the ranges came from in Column B on the same rows?
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":
The outcome of the process would look like the image below but without the colours or the additional "_b":
推荐答案
我不知道这是否正是您想要的,但是我认为它可以使您更加接近并为您提供一些有关如何进行的线索.我们可以对其进行修改以使其正确.
I don't know if this is exactly what you want, but I think it will get you closer and give you some clues on how to proceed. We can edit it to make it right.
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
这篇关于将范围从不同的工作簿复制到一个最终目标表中的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!