Добрый вечер.
Необходимо в базу копировать данные из россыпи отчетов. Отчеты все идентичные по структуре. Нашел макрос похожий, но он копирует в новую строку, а мне надо что бы копировал в ту строку, где в данный момент выделена ячейка. В выделенную ячейку так же должно копироваться значение. И еще, не знаю как изменить выбор что и куда копируется, что бы выбрать откуда именно из отчета и куда именно в базу должно вставляться значение.
Макрос:
Необходимо в базу копировать данные из россыпи отчетов. Отчеты все идентичные по структуре. Нашел макрос похожий, но он копирует в новую строку, а мне надо что бы копировал в ту строку, где в данный момент выделена ячейка. В выделенную ячейку так же должно копироваться значение. И еще, не знаю как изменить выбор что и куда копируется, что бы выбрать откуда именно из отчета и куда именно в базу должно вставляться значение.
Макрос:
| Код |
|---|
Option Explicit
Sub Кнопка10_Щелкнуть()
Dim FD As FileDialog
Dim ItogWb As Workbook
Dim ItogWsh As Worksheet
Dim iFileName As String
Dim iShortFileName As String
Dim iLastRow As Long
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Filters.Clear 'удаляет предопределенные фильтры
.Filters.Add "Microsoft Excel files", "*.xls"
.Filters.Add "All files", "*.*"
.AllowMultiSelect = False 'если True-то выбор нескольких файлов
.InitialFileName = ThisWorkbook.Path
.Title = "Открытие документа с исходными данными"
.ButtonName = "Открыть"
If .Show = False Then
MsgBox "Вы не указали нужный файл!", 48, "Ошибка"
Exit Sub
Else
iFileName = .SelectedItems(1)
iShortFileName = Right(.SelectedItems(1), Len(.SelectedItems(1)) _
- InStrRev(.SelectedItems(1), "\"))
'If Right(UCase(iFileName), 4) = ".XLS" Then iFileName = Left(iFileName, Len(iFileName) - 4)
End If
End With
Set FD = Nothing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
Set ItogWb = Workbooks.Open(Filename:=iFileName, UpdateLinks:=False, _
ReadOnly:=True)
Set ItogWsh = ItogWb.Worksheets("Лист1")
ThisWorkbook.Activate
With ItogWsh
Cells(iLastRow + 1, 1) = Cells(iLastRow, 1).Value + 1
Cells(iLastRow + 1, 2).Value = .Cells(5, 17)
Cells(iLastRow + 1, 3) = .Cells(5, 32)
Cells(iLastRow + 1, 4) = .Cells(1, 38) & .Cells(1, 43) & .Cells(2, 43)
Cells(iLastRow + 1, 5) = .Cells(5, 7)
Cells(iLastRow + 1, 6) = .Cells(5, 10)
Cells(iLastRow + 1, 7) = .Cells(5, 46)
Cells(iLastRow + 1, = .Cells(1, 48)
Cells(iLastRow + 1, 9) = .Cells(30, 6)
End With
ItogWb.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub |
Изменено: - 14.08.2018 16:53:38
