将数据从一个工作簿粘贴到另一个工作簿时，数据或数据不会全部显示。

我是VBA的新手，所以不太确定这一切是如何运作的，但我已经有了jist。 我正在尝试从多个工作簿导入数据到由该程序创build的一个工作簿中。 我已经正确地完成了主要的导入（尽pipe不是很有效），但是发生了三件事情之一：数据被导入到正确的位置并且很好，数据在第一组之后重叠，或者只有第一组数据被传送。 我只是不能解决为什么！

Do Filename = InputBox("What is the full path and name of the file?") Workbooks.Open (Filename) data_range = InputBox("What is the cell range of the wanted data in the original file? If this is the first set of data, include the titles for reference") ActiveSheet.Range(data_range).Select Selection.Copy ActiveWorkbook.Close If first = True Then ActiveSheet.Range("b2").Select End If If first = False Then ActiveSheet.Range("b" & (difference + 3)).Select End If ActiveSheet.Paste ActiveSheet.Range("a1").Select again = MsgBox("Would you like to import another set of data?", 4) Call start_cell(range_of_cells, data_range) first = False Loop Until again = vbNo 

这是主要的计划。 子程序start_cell如下：

  range_of_cells = Split(data_range, ":") NUMBERS(0) = Right(range_of_cells(0), 2) NUMBERS(1) = Right(range_of_cells(1), 2) check = IsNumeric(NUMBERS(0)) If check = False Then 'wrong End If check = IsNumeric(NUMBERS(1)) If check = False Then 'wrong End If difference = (NUMBERS(1) - NUMBERS(0)) + difference 

任何帮助都是极好的。 如果还有更有效的方法，那就太好了。

Answer 1

这是什么可以工作，检查，运行，定制它，让我知道如果有什么不工作，或者我误解了你的问题的草图。

 Function GetFolder(ByVal sTitle As String) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = sTitle .Show On Error Resume Next GetFolder = .SelectedItems(1) On Error GoTo 0 End With End Function Sub Main() Const START_ADDR As String = "A17" Dim sPath As String, sFile As String Dim wbLoop As Workbook Dim wsLoop As Worksheet, wsConsolidate As Worksheet Dim rData As Range 'save current sheet in variable (change if required) wsConsolidate = ActiveSheet 'ask for folder sPath = GetFolder("Select the folder where your files reside.") 'if none provided quit If sPath = "" Then MsgBox "No folder selected." Exit Sub End If 'get all excel files from specified folder sFile = Dir(sPath & "\*.xls*") Do Until sFile = "" 'open file Set wbLoop = Workbooks.Open(sPath & "\" & sFile) Set wsLoop = wbLoop.Sheets(1) 'change if other 'copy data out Set rData = wsLoop.Range(START_ADDR).CurrentRegion 'if the data has headers uncomment below 'Set rData = rData.Offset(1, 0).Resize(rData.Rows.Count) rData.Copy wsConsolidate.Cells(wsConsolidate.Rows.Count, "B").End(xlUp).Offset(1, 0) 'close file without saving wbLoop.Close False 'loop through files sFile = Dir Loop End Sub