|
Сохранение форматирования ячеек при копировании таблицы
#40060995
Ссылка:
Ссылка на сообщение:
Ссылка с названием темы:
|
|
|
|
Уважаемые форумчане, добрый день!
К сожалению мои познания в программировании скудны, прошу Вашей помощи, необходимо добавить функцию сохранения исходного форматирования данных при переносе их в новую книгу.
Сам пытался прикрутить .Value(11), но это не дало результатов, получаю ошибку в функции UBound.
Заранее спасибо!
Скрипт 1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
'вводные данные из книг
Const name1 = "имя книги1.xlsx"
Const name2 = "имя книги2.xlsx"
'задаем переменные
Sub BookBook()
Dim wb1 As Workbook
Dim wb2 As Workbook
'выводим сообщение об ошибке, если не найдена книга name1/name2
On Error Resume Next
Set wb1 = Workbooks(name1)
Set wb2 = Workbooks(name2)
On Error GoTo 0
If wb1 Is Nothing Then
MsgBox "File not found " & name1, vbExclamation
Exit Sub
End If
If wb2 Is Nothing Then
MsgBox "File not found " & name2, vbExclamation
Exit Sub
End If
'тут уже туго соображаю.. делаем массив вроде как, и обработка данных покнижно в таблице 1 (sheets(1))
Dim y As Long
Dim u As Long
Dim dicY As Object
Set dicY = CreateObject("Scripting.Dictionary")
Dim ar1 As Variant
Dim ar2 As Variant
With wb1.Sheets(1)
y = .Cells(.Rows.Count, 1).End(xlUp).Row
ar1 = .Range(.Cells(1, 1), .Cells(y, [P1].Column))
End With
With wb2.Sheets(1)
y = .Cells(.Rows.Count, 1).End(xlUp).Row
ar2 = .Range(.Cells(1, 1), .Cells(y, [P1].Column))
End With
'обозначаем столбцы из книги 1, которые оставить пустыми
For y = 2 To UBound(ar1, 1)
dicY.Item(CStr(ar1(y, 1))) = y
ar1(y, 3) = Empty
ar1(y, 10) = Empty
ar1(y, 11) = Empty
ar1(y, 12) = Empty
ar1(y, 15) = Empty
Next
'заполняем пустые столбцы данными из таблицы 2(иначе говоря заменяем данные в столбцах на нужные нам из табл.2)
For y = 2 To UBound(ar2, 1)
If dicY.Exists(CStr(ar2(y, 1))) Then
u = dicY.Item(CStr(ar2(y, 1)))
ar1(u, 3) = ar2(y, 12)
ar1(u, 10) = ar2(y, 9)
ar1(u, 11) = ar2(y, 8)
ar1(u, 12) = ar2(y, 14)
ar1(u, 15) = ar2(y, 13)
End If
Next
'создаем книгу 3 и переносим туда наши данные
Dim wb3 As Workbook
Set wb3 = Workbooks.Add(1)
wb3.Sheets(1).Cells(1, 1).Resize(UBound(ar1, 1), UBound(ar1, 2)) = ar1
End Sub
|
|
|
