Копирование диапазона данных в таблицу на другую книгу

Question

Я пытаюсь сделать макрос, который бы скопировал диапазон данных из рабочей книги, которая в настоящее время открыта, в первую пустую строку таблицы в другой книге, которая хранится в сети. (он будет служить базой данных для ввода данных i в моем файле)

Мой выбор для Excel зависит от его возможностей анализа данных, так как данные должны постоянно контролироваться и анализироваться и сохраняться для записей, данных до 1 миллиона строк в год.

Какой код я должен использовать для достижения этого? много часов поиска не повезло до сих пор, любая помощь приветствуется, СПАСИБО! :)

PS Я попытаюсь связать приблизительно 10 файлов с данными в тот же файл (База данных), но, как другие люди могут открыть базу данных , это вызовет проблемы с вложением информации в базу данных?

Answer 1

-edit: Просто добавьте объяснение для тех, кто может смириться с решениями. Главное, что мы делаем, одновременно открывать обе рабочие книги и переключаться между ними, используя Windows(some_workbook).Activate, где some_workbook - это название книги. Его можно найти с помощью ActiveWorkbook.Name Обычно это имя файла с расширением (это одна из причин, по которой excel не позволяет открывать книги с тем же именем, даже если путь отличается, поскольку он использует только имя файла в качестве дескриптора он не может различать два физически разных файла с тем же именем)

Если одна рабочая книга не открыта, мы используем workbook.open Filename:= "PATH_TO_WORKBOOK", где PATH_TO_WORKBOOK - это полный путь к книге, которую вы хотите открыть. Также обратите внимание, что он окружен котировками

Помимо управления книгами, вам, вероятно, необходимо управлять листами (если у вас нет простых 1 листовых книг) с использованием sheets(sheet_name).activate, где sheet_name - это имя листа в виде строки. Он также может быть индексом листа (хорош для повторения нескольких листов), но, как правило, не так надежен, поскольку листовые заказы могут быть смешаны или листы могут быть добавлены/удалены. Уверенные пользователи могут изменять имена листов, но это легче предотвратить, сохраняя при этом гибкость. see here 'preventing users chaning sheetnames'

Вам также необходимо отслеживать два диапазона: тот, который вы копируете, и тот, который вы вставляете.

После того, как вы получите все, что сделано, его просто скопировать и вставить операции

Ok Heres ваше решение. Я пошел в vba и создал два модуля. Первый FILE_FUNCTIONS

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
'this function opens the windows file explorer and allows 
 
'the user to open a file 
 
'PARAMS: N/A 
 
'RETURN: the name of the file if the user picked a file 
 
'  OW returns "" 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
Function GuiOpenSpecifiedFile(file_dialog_title, _ 
 
    Optional Txt_only As Boolean, Optional CSV_only As Boolean) 
 
'this creates a filedialog object 
 
Set my_fd = Application.FileDialog(msoFileDialogFilePicker) 
 

 
With my_fd 
 
    'this sets the title 
 
    .Title = file_dialog_title 
 

 
    'this is so they can only pick one file at a time 
 
    .AllowMultiSelect = False 
 
    
 
    'this just makes sure they can select anyfile 
 
    .Filters.clear 
 
    
 
    'adds filters if specified 
 
    If (Not (IsMissing(Txt_only)) And Txt_only) Then 
 
     .Filters.Add "Text", "*.txt" 
 
    End If 
 
    
 
    If (Not (IsMissing(CSV_only)) And CSV_only) Then 
 
     .Filters.Add "CSV", "*.csv" 
 
    End If 
 
    
 
    'this makes the window pop up and saves the selected 
 
    'file to a variable 
 
    file_to_import = .Show 
 
    
 
End With 
 
     
 
     
 
'makes sure they actually chose a file 
 
If (file_to_import <> 0) Then 
 
    
 
    'this takes the name of the file selected and stores 
 
    'it in a variable 
 
    GuiOpenSpecifiedFile = Trim(my_fd.SelectedItems(1)) 
 
    
 
Else 
 
    'return null value 
 
    GuiOpenSpecifiedFile = "" 
 
End If 
 

 
End Function 
 

 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
'tells whether or not a specifc file exists 
 
'PARAMS: the full path to the file, or the file name if it 
 
'  is in the same working directory 
 
'RETURN: wthere the file exists 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
Function FileExists(sFile_path As String) As Boolean 
 
'if file exists DIR returns the file name, or blank otherwise 
 
'if you run DIR("") it returns the workbook title which has a len > 0 
 
'so we also have to check the file name itsel 
 
FileExists = ((Len(Dir(sFile_path)) > 0) And (Len(sFile_path) > 0)) 
 

 
End Function 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
'this finds the last row in an excel worksheet 
 
'PARAMS: Opt: sheet_name, the sheet you want to check last row of 
 
'    default is current sheet if not specified 
 
'RETURN: the last row number used in the sheet 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
Function GetLastRow(Optional sheet_name As String) 
 

 
'gets current sheet name 
 
the_current_sheet = ActiveSheet.Name 
 

 
'if the user specified a sheet, select it 
 
If (Len(sheet_name) <> 0) Then 
 
    Sheets(sheet_name).Select 
 
End If 
 

 
'finds the last row 
 
GetLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
 

 
'returns to original sheet 
 
Sheets(the_current_sheet).Select 
 
End Function 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
'this finds the last row in a specific column 
 
'PARAMS: col_to_check, the clumn we want the last row of 
 
'  Opt: sheet_name, the sheet you want to check last row of 
 
'    default is current sheet if not specified 
 
'RETURN: the last row number used in the sheet 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
Function GetLastRowByColumn(col_to_check As String, Optional sheet_name As String) 
 

 
'gets current sheet name 
 
the_current_sheet = ActiveSheet.Name 
 

 
'if the user specified a sheet, select it 
 
If (Len(sheet_name) <> 0) Then 
 
    Sheets(sheet_name).Select 
 
End If 
 

 
'gets last row 
 
GetLastRowByColumn = Range(col_to_check & "65536").End(xlUp).Row 
 

 
'returns to original sheet 
 
Sheets(the_current_sheet).Select 
 
End Function 
 

 
'--------------------------------------------------------------------------------- 
 
'checks whether or not a sheet exists by looking for its name in the currently 
 
'opened sheets 
 
'PARAMS: sSheetName, as string of the sheetname you want to find 
 
'RETURN: boolean, wehther sheet exists 
 
'--------------------------------------------------------------------------------- 
 
Function SheetExists(ByVal sSheetName As String) As Boolean 
 

 
Dim oSheet As Excel.Worksheet 
 
Dim bReturn As Boolean 
 

 
For Each oSheet In ActiveWorkbook.Sheets 
 

 
    If oSheet.Name = sSheetName Then 
 

 
     bReturn = True 
 
     Exit For 
 

 
    End If 
 

 
Next oSheet 
 

 
SheetExists = bReturn 
 

 
End Function

Так скопировать все те, в модуль и назовите его FILE_FUNCTIONS (это экономит массу времени, чтобы сохранить этот модуль самостоятельно и импортировать его в будущих проектах)

Второй модуль имеет фактический код. Здесь вы должны внести изменения в суб «Sub CopCellsFromSheetToDataBase», чтобы получить файл базы данных и установить столбцы и диапазоны

Function OpenWorkbook(spath_to_workbook) 
 
'check if the file exists 
 
If Not (FILE_FUNCTIONS.FileExists(CStr(spath_to_workbook))) Then 
 
    OpenWorkbook = "" 
 
    Exit Function 
 
End If 
 

 
'surrounds the file name with quotes as required 
 
'spath_to_workbook = Chr(34) & spath_to_workbook & Chr(34) 
 
Workbooks.Open Filename:=spath_to_workbook 
 

 
'returns the name of the workbook 
 
OpenWorkbook = ActiveWorkbook.Name 
 
End Function 
 

 

 
Sub CopyCellsFromSheetToDatabase() 
 
Dim db_sheetname, db_record_col As String 
 

 
'------------- start configuration ------------------- 
 
smy_range_to_copy = "A1:B2" 
 
db_sheetname = CStr("AllRecords") 'cstr must be ppresent 
 
db_record_col = "A" 
 

 
sdb_filename = FILE_FUNCTIONS.GuiOpenSpecifiedFile("Please select the database file") 
 

 
'or if you want it to simply be hardcoded you can do that 
 
'sdb_filename = "c:\users\administrator\desktop\my_database.xlsx") 
 
'-------------- end configuration ------------------ 
 

 
'if the user didn't select a file quit sub quietly 
 
If Len(sdb_filename) = 0 Then 
 
    Exit Sub 
 
End If 
 

 
Application.StatusBar = "Copying to database" 
 
Application.ScreenUpdating = False 
 

 
'saves the workbook names 
 
curr_workbook = ActiveWorkbook.Name 
 
database_workbook = OpenWorkbook(sdb_filename) 
 

 
'if we opened the file 
 
If (Len(database_workbook) = 0) Then 
 
    MsgBox ("Unable to Open workbook " & sdb_filename) 
 
    Exit Sub 
 
End If 
 

 
'copies range 
 
Windows(curr_workbook).Activate 
 
Range(smy_range_to_copy).Select 
 
Selection.Copy 
 

 
'switches to db 
 
Windows(database_workbook).Activate 
 

 
'checks if the db_Sheet exists 
 
If (Not (FILE_FUNCTIONS.SheetExists(db_sheetname))) Then 
 
    MsgBox ("Sheet: " + db_sheetname + vbLf + " not found in: " + sdb_filename) 
 
    
 
    ActiveWorkbook.Close 
 
    
 
    'activates the original workbook (in case you have many others open) 
 
    Windows(curr_workbook).Activate 
 
    
 
    'restores app settings 
 
    Application.StatusBar = "" 
 
    Application.ScreenUpdating = True 
 
    
 
    Exit Sub 
 
End If 
 

 

 
'use this if you want only the last row from a particular column and have a sheetname 
 
last_row_of_db = FILE_FUNCTIONS.GetLastRowByColumn(db_record_col, CStr(db_sheetname)) 
 

 
'pastes the values 
 
Range(db_record_col & CStr(last_row_of_db + 1)).Select 
 
ActiveSheet.Paste 
 
Application.CutCopyMode = False 
 

 
'saves the db and closes it 
 
ActiveWorkbook.Save 
 
ActiveWindow.Close 
 

 
'activates the original workbook (in case you have many others open) 
 
Windows(curr_workbook).Activate 
 

 
'returns control to excel 
 
Application.StatusBar = "" 
 
Application.ScreenUpdating = True 
 
End Sub