excel - 从多个工作簿复制特定数据
问题描述
我是 VBA 的新手,我一直在尝试创建一个程序来将特定范围从具有工作表 2 数据的多个工作簿复制到主工作簿工作表 2 。
COPY 条件:列范围为 A20 到 AS20,而行范围取决于 R 列中包含数据的最后一个单元格。
粘贴条件:从A20行开始,连续粘贴所有复制的单元格,中间有一个空白行
复制粘贴条件:范围 D5 : D18 从原始书籍到主表,以重叠方式,因为所有原始书籍的范围都相同。
我来到了下面的阶段,但不知道继续前进。做了一些更正,但效果不佳。
前卫:
Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String
Dim masterBook As Workbook
Dim sourceBook As Workbook
Dim insertRow As Long
Dim copyRow As Long
insertRow = 20
Set masterBook = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with source files"
If Not .Show = 0 Then
BrowseFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False
Set oFolder = FSO.getfolder(BrowseFolder)
masterBook.Sheets("Service Order Template").Cells.UnMerge
For Each FileItem In oFolder.Files
If FileItem.Name Like "*.xls*" Then
Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set sourceBook = Workbooks(FileItem.Name)
With sourceBook.Sheets("Service Order Template")
.Cells.UnMerge
copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
Application.CutCopyMode = False
.Parent.Close SaveChanges:=False
End With
insertRow = masterBook.Sheets("Service Order Template").Cells(Rows.Count, 18).End(xlUp).Row + 2
End If
Next
Application.ScreenUpdating = True
End Sub
解决方案
检查这个。如果有问题,请参阅代码中的注释 - 将注释放在答案中。希望你能找到新的东西。您必须将此代码放入主工作簿中的模块。
Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String
Dim masterBook As Workbook
Dim sourceBook As Workbook
Dim insertRow As Long
Dim copyRow As Long
' add variables for blank check
Dim checkRange As Range, r As Range
insertRow = 20
Set masterBook = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with source files"
If Not .Show = 0 Then
BrowseFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False
Set oFolder = FSO.getfolder(BrowseFolder)
masterBook.Sheets("Service Order Template").Cells.UnMerge
For Each FileItem In oFolder.Files
If FileItem.Name Like "*.xls*" Then
Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set sourceBook = Workbooks(FileItem.Name)
With sourceBook.Sheets("Service Order Template")
.Cells.UnMerge
copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
' copy additional needed range D5 : D18 from source to range D5 on master
Range(.Cells(5, 4), .Cells(18, 4)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(5, 4)
Application.CutCopyMode = False
.Parent.Close SaveChanges:=False
End With
masterBook.Sheets("Service Order Template").insertRow = .Cells(Rows.Count, 18).End(xlUp).Row + 2
End If
Next
With masterBook.Sheets("Service Order Template")
' if you don't need to highlight the whole row - remove the ".EntireRow" part →---→---→----↓
Range(.Cells(20, 18), .Cells(Rows.Count, 18).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow
End With
Application.ScreenUpdating = True
End Sub
推荐阅读
- c# - 如何正确扩展 ASP.NET MVC 中的 ApplicationUser?
- javascript - 生成GeoJson,如何使用NewLine?
- visual-studio-2013 - 如何在vsts中移动文件夹位置?
- java - 使用 RS-422 进行 Java 串行通信
- javascript - 范围问题,嵌套函数中未定义的变量
- javascript - 从 NPM 安装 CRA 和 NextJS 时出现问题(错误:在“npm”注册表中找不到包“@babel/core”)
- groovy - 请求日志中的请求失败[连接被拒绝]并且soapui中没有响应时脚本断言未运行
- javascript - create-react-app newproject 命令行对我不起作用
- php - Ubuntu 18.04 上的 PHP 启动问题
- python-3.x - Python BeautifulSoup:根据颜色属性获取表格元素