[英]Subscript out of range Error in Copying cell value
我正在使用这个脚本。 我在下面用注释指示的行中得到下标超出范围错误
'This is the section to customize, replace with your own action code as needed**
我正在尝试将名为One Pager的工作表中存在的单元格值E3
复制到文件SUMMARY1.xlsm
中的工作表中
我得到了结果,但我确实得到了超出范围的错误。 不确定发生了什么。 该代码在多个文件的One Pager实例中查找单元格E3
。
文件夹路径 = C:\Users\guhaka\OneDrive - Danone\Documents\Portfolio Optimization\rTAM Presentation\Dossier\
Sub Something() '‹~~ Added this to indent the code. Please change to real name
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("Master") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
Cells.Select
Selection.UnMerge
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = "C:\Users\guhaka\OneDrive - Danone\Documents\Portfolio Optimization\rTAM Presentation\Dossier\" 'remember final \ in this string
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xlsm*") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
Sheets("One Pager").Range("E3").Copy
wbData.Close False 'close file
Workbooks("SUMMARY1.xlsm").Activate
ActiveSheet.Range("E3").Select
ActiveSheet.Paste
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
fName = Dir 'ready next filename
End If
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
以下是避免覆盖的方法:
'...
'...
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'copy E3 to the next empty cell on the summary sheet
' (adjust sheet/workbook as needed)
wbData.Sheets("One Pager").Range("E3").Copy _
ThisWorkbook.Sheets("Summary").cells(Rows.Count, "E").End(xlUp).offset(1, 0)
wbData.Close False 'close file
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
fName = Dir 'ready next filename
End If
Loop
'...
'...
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.