正在提取一系列不连续的单元格

Question

在特定文件夹中的excel文件中提取一系列不连续的单元格(数据必须从两张独特的表格中提取(

我有下面的代码来提取不连续的数据(单元格范围(，并将它们粘贴到新的工作表中。然而，代码需要在两张表中的任一张表中查找数据，即-"0"；summary1"；或"；extract1"；。

[注意-每个文件中只有两张纸中的一张可用]我可以成功地拉动其中一个，但如果我使用"；On Error Resume Next"；我弄错了。请指导我如何解决这个问题！

非常感谢任何建议或提示！！

代码：

Sub PIdataextraction()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "C:UsersNew"
myFile = Dir(path & "*.xl??")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("summary1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
On Error Resume Next
Set copyrange = Sheets("extract1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
Windows("MasterFile.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub

Answer 1

这里有一种方法，它将"；在工作簿中找到其中一张"；逻辑转换为单独的函数。

Sub PIdataextraction()
Const PTH As String = "C:UsersNew" 'use const for fixed values
Const RNG As String = "B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16"

Dim myFile As String, path As String, c As Range
Dim erow As Long, col As Long, wb As Workbook, ws As Worksheet

Application.ScreenUpdating = False

erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
myFile = Dir(PTH & "*.xl??")

Do While myFile <> ""
Set wb = Workbooks.Open(path & myFile)

Set ws = FindFirstSheet(wb, Array("summary1", "extract1"))
If Not ws Is Nothing Then       'check we got a sheet
col = 1
For Each c In ws.Range(RNG).Cells
Sheet1.Cells(erow, col).Value = c.Value
col = col + 1
Next c
Sheet1.Cells(erow, col).Value = wb.Name '<<<<<<<<<<<<<<<<
erow = erow + 1
Else
Debug.Print "No sheet found in " & ws.Name
End If

wb.Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Data has been Compiled,Please Check!"
End Sub
'Given a workbook `wb`, return the first sheet found from 
'  an array of sheet names `SheetNames`
Function FindFirstSheet(wb As Workbook, SheetNames) As Worksheet
Dim ws As Worksheet, s
For Each s In SheetNames
On Error Resume Next
Set ws = wb.Worksheets(s)
On Error GoTo 0
If Not ws Is Nothing Then Exit For
Next s
Set FindFirstSheet = ws
End Function

Answer 2

下面的代码对我很有用。像往常一样，感谢您的宝贵投入！！备受关注的

子PIdataextraction((

Dim myFile As String, path As String
Dim erow As Long, col As Long

Dim shtSrc As Worksheet
Dim copyrange As Range, cel As Range

path = "C:UsersNew"
myFile = Dir(path & "*.xl??")

Application.ScreenUpdating = False

Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate

On Error Resume Next
Set shtSrc = Worksheets("summary1")
If Err = 9 Then
On Error Resume Next
Set shtSrc = Worksheets("extract1")
If Err = 9 Then Exit Sub
On Error GoTo 0
End If

Set copyrange = shtSrc.Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")

Windows("MasterFile.xlsm").Activate

erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

col = 1
For Each cel In copyrange
Cells(erow, col).Value = cel.Value   ' Equivalent of xlPasteValues
col = col + 1     
Next

Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Data has been Compiled,Please Check!"
End Sub