Копирование определенных столбцов в новый документ

@GrigorMaklauds · Регистрация: 27.01.2017

Author24 — интернет-сервис помощи студентам

Здравствуйте.
У меня возникли сложности с созданием новой таблицы из исходной. Я сделал макрос, но не думаю что он оптимальный и универсальный. Поэтому и хочу , чтобы вы оценили и может подсказали, как его усовершенствовать.
Пока копируется таблицы с 1 исходного листа на уже созданный 2 лист

Дано: Книга, с большим количеством листов. На каждом листе по 2 - n таблиц. Они идут подряд, через пустые строки.
Для примера у меня 1 исходный лист с 2 таблицами. Так как дальше все однотипно.

Задача:
Нужно создать таблицу ("Наименование","Обозн","Разм","Мин","Макс","Частота об","Примечание").
Нюанс в том, что на некоторых листах в таблицах есть столбец Размерность (он же "Разм"), а в некоторых нет. Например
на 1 листе этого столбца нету. И поэтому, чтобы не нарушать порядок столбцов я его добавляю, если он не найден.

Вот мой код

Visual Basic

Sub Test()
Dim Arr(1 To 10, 1 To 1000) As String ' 1 строчка - Наименование сигнала , 2 - обозначение сигнала , 3 - Размерность, 4 - минимальное, 5 - максимальное значение , 6 - частота обновления , 7 - примечание
Dim Z As Integer
Dim c As Range
Dim r As Range
Z = 1
k = 0
i = 1
Dim boolka As Boolean
boolka = False
 
Caption = Array("Наименование", "Обозн", "Разм", "Мин", "Макс", "Частота об", "Примечание")
 
For w_count = 1 To Worksheets.Count 'бегаю по листам
LastRow = Worksheets(w_count).UsedRange.Row + Worksheets(w_count).UsedRange.Rows.Count - 1
For k = 0 To UBound(Caption)
   Set c = Worksheets(w_count).Cells.Find(What:=Caption(k))
   Set r = Worksheets(w_count).Cells.Find(What:=Caption(k))
   If Not c Is Nothing Then
    Z = 1
        For Each j In Worksheets(w_count).Range(Worksheets(w_count).Cells(r.Row + 1, c.Column), Worksheets(w_count).Cells(LastRow, c.Column)) 'бегаю по стобцам
            If ((j.Borders.LineStyle = xlNone) = False Or IsNull(j.Borders.LineStyle = xlNone)) And (j.Interior.ColorIndex < 0) Then
                Arr(i, Z) = j.Value
                Z = Z + 1
            End If
        Next j
  i = i + 1
  Else
  boolka = True
End If
Next k
Next w_count
 
For i = 1 To 10 ' выгружаю массив
    For j = 1 To 1000
   Worksheets(2).Cells(j + 1, i + 1) = Arr(i, j)
    Next j
Next i
 
If boolka Then
Worksheets(2).Columns(4).Insert
End If
 
Worksheets(2).Cells(1, 2).Resize(, UBound(Caption) + 1) = Caption
 
End Sub

Вся проблема в цикле for each . вы сами видите. Чтобы в массива загружать только поля таблицы, и не загружать заголовок и пустые строки я использую условие :
If ((j.Borders.LineStyle = xlNone) = False Or IsNull(j.Borders.LineStyle = xlNone)) And (j.Interior.ColorIndex < 0) Then
Он мне не нравится, но другого способа я не нашел.

Повторюсь, хотел бы узнать как все это можно более человечески сделать

Забыл добавить в итоге должна получиться одна таблица из всех, которые есть на исходном листе. Т.е все таблицы с 1 листа преобразуются в 1 таблицу на новом и тд
Надеюсь я нормально объяснил)

@GrigorMaklauds · 09.11.2017, 22:31 **[ТС]**

Мне кажется, что все слишком громозко получилось. Слишком много лишнего, а как упростить я не знаю

@fever brain · 09.11.2017, 23:50

Конечно сделанно криво, что собой представляет таблица ? А еще не одна ?
Бери макрос копии формата и копируй на новый лист все свои таблицы

а экспорт таблиц не пробовал ?

копию листа в конце концов ?

@GrigorMaklauds · 10.11.2017, 07:39 **[ТС]**

Вы правы. Спасибо. Решил себе проблем сделать. Можно было лист скопировать, а уже потом удалять и всталять столбцы.

@GrigorMaklauds 1 / 1 / 0 Регистрация: 27.01.2017 Сообщений: 20
	09.11.2017, 22:31 [ТС]	2
	Мне кажется, что все слишком громозко получилось. Слишком много лишнего, а как упростить я не знаю 0

@fever brain oh my god 1454 / 793 / 161 Регистрация: 05.01.2016 Сообщений: 2,307 Записей в блоге: 8
	09.11.2017, 23:50	3
	Конечно сделанно криво, что собой представляет таблица ? А еще не одна ? Бери макрос копии формата и копируй на новый лист все свои таблицы а экспорт таблиц не пробовал ? копию листа в конце концов ? 0

@GrigorMaklauds 1 / 1 / 0 Регистрация: 27.01.2017 Сообщений: 20
	10.11.2017, 07:39 [ТС]	4
	Вы правы. Спасибо. Решил себе проблем сделать. Можно было лист скопировать, а уже потом удалять и всталять столбцы. 0