Прошу прощения, если этот вопрос уже задавался. Я искал и нашел только один запрос, который в некоторой степени связан с моей ситуацией: как объединить сотни файлов электронных таблиц Excel? ,
Я изменил код, предоставленный Крисом Кентом в связанном посте, чтобы попытаться решить мою проблему.
Здесь я пытаюсь получить определенный диапазон данных из нескольких рабочих книг и вставить их в одну с помощью VBA в Excel 2010. В конце концов я добавлю сводную страницу с суммой каждого набора данных. На данный момент моей главной проблемой является получение информации из нескольких рабочих книг для успешного копирования.
Каждый диапазон одинаков в каждой книге.
Мне не нужно тянуть заголовки.
Мне нужен только 1 лист данных.
В коде, которым я манипулировал, чтобы лучше соответствовать моим требованиям ниже, я сталкиваюсь со следующими проблемами:
Данные из первых двух файлов (даты 11-23-15 и 11-24-15) не переносятся. У меня есть ощущение, что это связано с неотредактированной частью кода, которую я еще не коснулся относительно удаления столбцов / строк с нулями, показанными ниже.
Private Function GetTrueEnd(ws As Worksheet) As Range Dim lastRow As Long Dim lastCol As Long Dim r As Long Dim c As Long On Error Resume Next lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row On Error GoTo 0 If lastCol <> 0 And lastRow <> 0 Then ' look back through the last rows of the table, looking for a non-zero value For r = lastRow To 1 Step -1 For c = 1 To lastCol If ws.Cells(r, c).Text <> "" Then If ws.Cells(r, c).Text <> 0 Then Set GetTrueEnd = ws.Cells(r, lastCol) Exit Function End If End If Next c Next r End If Set GetTrueEnd = ws.Cells(1, 1) End Function
Дата из первого файла (как имя файла) указана в столбце B, а дата из второго файла - в столбце C, когда они должны быть указаны в столбце E. Это может быть частью того же предположения, которое я имею на # 1.
Данные с 11-25-15 и 11-26-15 имеют #REF! ошибка. Я надеюсь, что если я пойму, как извлекать только значения, а не формулы, это исправит эту ошибку. Тем не менее, это не происходит в другие даты, поэтому я не уверен, является ли это основной проблемой. Единственное место, которое я знаю, чтобы попытаться использовать.Значение 'или'.Pastespecial 'коды в следующем, но я еще не получил его работать:
If mainLastEnd(i).Row > 1 Then ' There is data in the sheet ' Copy new data (skip headings) externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)
Если бы кто-нибудь мог помочь мне решить вышеупомянутые проблемы, я был бы очень признателен.
Вот весь код:
Option Explicit
Const NUMBER_OF_SHEETS = 1
Public Sub GiantMerge()
Dim externWorkbookFilepath As Variant
Dim externWorkbook As Workbook
Dim i As Long
Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
Dim mainCurEnd As Range
Application.ScreenUpdating = False
' Initialise
' Correct number of sheets
Application.DisplayAlerts = False
If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
ThisWorkbook.Sheets(i).Delete
Next i
End If
Application.DisplayAlerts = True
For i = 1 To NUMBER_OF_SHEETS
Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
Next i
' Load the data
For Each externWorkbookFilepath In GetWorkbooks()
Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)
For i = 1 To NUMBER_OF_SHEETS
If mainLastEnd(i).Row > 1 Then
' There is data in the sheet
' Copy new data (skip headings)
externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)
' Find the end column and row
Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
Else
' No data in sheet yet (prob very first run)
' Get correct sheet name from first file we check
ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name
' Find the end column and row
Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)
End If
' Add file name into extra column
ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name
Set mainLastEnd(i) = mainCurEnd
Next i
externWorkbook.Close
Next externWorkbookFilepath
Application.ScreenUpdating = True
End Sub
' Returns a collection of file paths, or an empty collection if the user selects cancel
Private Function GetWorkbooks() As Collection
Dim fileNames As Variant
Dim xlFile As Variant
Set GetWorkbooks = New Collection
fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
FileFilter:="Excel Files, *.xlsm;*.xlsx", _
MultiSelect:=True)
If TypeName(fileNames) = "Variant()" Then
For Each xlFile In fileNames
GetWorkbooks.Add xlFile
Next xlFile
End If
End Function
' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
Private Function GetTrueEnd(ws As Worksheet) As Range
Dim lastRow As Long
Dim lastCol As Long
Dim r As Long
Dim c As Long
On Error Resume Next
lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
On Error GoTo 0
If lastCol <> 0 And lastRow <> 0 Then
' look back through the last rows of the table, looking for a non-zero value
For r = lastRow To 1 Step -1
For c = 1 To lastCol
If ws.Cells(r, c).Text <> "" Then
If ws.Cells(r, c).Text <> 0 Then
Set GetTrueEnd = ws.Cells(r, lastCol)
Exit Function
End If
End If
Next c
Next r
End If
Set GetTrueEnd = ws.Cells(1, 1)
End Function