好的，所以我现在已经在这段代码上工作了几天，并且工作得很好，但是我一直在尝试添加一些行来提取不如复制和粘贴那么容易的数据，并且此后一直困扰不已。我正在寻找一些帮助完成/修复代码的帮助，也欢迎其他使代码更有效的方法。我之所以这样说是因为我在这里和那里做一些编码，但是我要注意一个编码器。大多数情况是使用Google搜索其他人，然后将它们拼凑在一起，然后进行调试，直到我将其投入使用为止，因此，如果出现问题，或者其中有些东西没有理由，我不知道。因此，请再次随意清理工作。
我创建了一个模块，用于从文件夹中的每个文件中提取多个数据，并将其带入新文档的表中。我已经能够提取简单的复制和粘贴内容，但是为了使事情更加自动化，我尝试添加一些行以提取文档的其他部分以放入表格中。源文件是数据收集运行，并且格式相同。更容易复制和粘贴的部分只是数字数据值（F6：H6和F7：H7）。非数字值是所有其他行。这些其他项目可以复制和粘贴，但问题是我只想要其中的一部分。因此，我从源文件的A1中提取的数据示例是运行标题，其格式为：“运行##-'运行描述'”，但我只需要运行编号。因此，如果我复制并粘贴，它会像“ 另一个要注意的是，我从所有包含公式的单元格中提取数据的值。这就是为什么我在方便复制和粘贴行中使用pastespecial的原因，但是我不确定这是否会成为其他行的解决方案中的一个因素。
到目前为止，我的代码：
Sub Summary()
Dim xFd As FileDialog
Dim xSPath As String
Dim xXLSXFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
rowTarget = 8
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
'xWsheet = ActiveWorkbook.Name
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.Title = "Select a folder:"
If xFd.Show = -1 Then
xSPath = xFd.SelectedItems(1)
Else
Exit Sub
End If
If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
'set up the target worksheet
Set wsTarget = Sheets(1)
'loop through the Excel files in the folder
xXLSXFile = Dir(xSPath & "*.xlsx")
Do While xXLSXFile <> ""
If xXLSXFile <> ThisWorkbook.Name Then
Set wbSource = Workbooks.Open(xSPath & xXLSXFile)
Set wsSource = wbSource.Worksheets(1)
''With wsTarget
''.Range("A" & rowTarget).Value = wsSource.Range("Runnum").Value
''End With
With wsSource
''.Range("Runnum").Value = wsTarget.Range("A" & rowTarget).Value
''.Names("Runnum").RefersToRange.Value
''wsTarget.Range("B" & rowTarget).Value
''.Range("A1").Value = Mid(str, 5, InStr(str, " ") - 5).Copy
''wsTarget.Range("A" & rowTarget).PasteSpecial xlPasteValues
''.Range("Runnum").Copy
''wsTarget.Range("A" & rowTarget).PasteSpecial xlPasteValues
.Range("A1").Copy
wsTarget.Range("A" & rowTarget).PasteSpecial xlPasteValues 'Run# 'remove first 4 characters and all characters after number/from the "-" -1
.Range("B4").Copy
wsTarget.Range("B" & rowTarget).PasteSpecial xlPasteValues
.Range("F6:H6").Copy
wsTarget.Range("C" & rowTarget).PasteSpecial xlPasteValues
.Range("F7:H7").Copy
wsTarget.Range("F" & rowTarget).PasteSpecial xlPasteValues
.Range("D1").Copy
wsTarget.Range("I" & rowTarget).PasteSpecial xlPasteValues 'remove first 7 characters
.Range("B9").Copy
wsTarget.Range("J" & rowTarget).PasteSpecial xlPasteValues
.Range("B13").Copy
wsTarget.Range("K" & rowTarget).PasteSpecial xlPasteValues 'remove every thing after the fist space -1
End With
End If
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
xXLSXFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
我已将循环中的几行代码转换为带有''的注释，以显示我尝试过的一些内容。确实，我保留了它们以帮助调试，但我还是把它们留了下来。
编辑：非常感谢大家的帮助！我对在此站点上获得的支持始终感到非常满意。还要感谢您对我和我的编码技巧的精打细算，或者缺乏这些技巧。:-)
以下是有关更改和所需提取的一些建议：
Option Explicit
Sub Summary()
Dim xFd As FileDialog
Dim xSPath As String
Dim xXLSXFile As String 'file to process
Dim wbTarget as workbook, wsTarget As Worksheet, rwTarget As Range, v
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
xSPath = GetAFolder("Select a folder:") 'extract code to re-usable function
If Len(xSPath) = 0 Then Exit Sub
Set wbTarget = ActiveWorkbook '## Target workbook
Set wsTarget = wbTarget.Worksheets(1) 'set up the target worksheet
Set rwTarget = wsTarget.Rows(8)
xXLSXFile = Dir(xSPath & "*.xlsx") 'loop through the Excel files in the folder
Do While xXLSXFile <> ""
If xXLSXFile <> wbTarget.Name Then
Set wbSource = Workbooks.Open(xSPath & xXLSXFile)
With wbSource.Worksheets(1)
rwTarget.Columns("A").Value = RunNumber(.Range("A1").Value) 'call function
rwTarget.Columns("B").Value = .Range("B4").Value
rwTarget.Columns("C").Resize(1, 3).Value = .Range("F6:H6").Value
rwTarget.Columns("F").Resize(1, 3).Value = .Range("F7:H7").Value
v = .Range("D1").Value
rwTarget.Columns("I").Value = Right(v, Len(v) - 7) 'remove first 7 chars from D1
rwTarget.Columns("J").Value = .Range("B9").Value
rwTarget.Columns("K").Value = Split(.Range("B13").Value, " ")(0) 'up to first space
End With
End If
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
Set rwTarget = rwTarget.Offset(1, 0)
xXLSXFile = Dir()
Loop
errHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'typically there's no need to set objects to Nothing when you're done...
End Sub
'extract the run number
Function RunNumber(ByVal v)
v = UCase(Trim(Split(v, "-")(0))) 'the part before the dash
RunNumber = Trim(Replace(v, "RUN", ""))
End Function
'push this out into a re-usable function
Function GetAFolder(dlgTitle As String) As String
Dim rv As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = dlgTitle
If .Show = -1 Then
rv = .SelectedItems(1)
If Right(rv, 1) <> "\" Then rv = rv & "\"
End If
End With
GetAFolder = rv
End Function
本文收集自互联网，转载请注明来源。
如有侵权，请联系[email protected] 删除。
我来说两句