Страницы: 1
RSS
Нужно расширить возможности макроса, Не очень удобный существующий макрос для печати
 
Код
Sub четырнадцать()
Dim q, w As Integer

q = 1
w = 0
Do While Not IsEmpty(Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 5).Value)
w = w + 1

Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 1).Value = (0 + q) & "."
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 2).Value = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 5).Value
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 3).Value = "Стальной выпуск опоры " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 5).Value
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 4).Value = "Сварка"
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 6).Value = "200"
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 7).Value = "0.04"
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 9).Value = "годно"
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 4), Cells(21 + q, 5)).Merge
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 7), Cells(21 + q, ).Merge
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 9), Cells(21 + q, 10)).Merge
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 4), Cells(21 + q, 5)).Borders.LineStyle = -xlContinuos
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 7), Cells(21 + q, ).Borders.LineStyle = -xlContinuos
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 9), Cells(21 + q, 10)).Borders.LineStyle = -xlContinuos
q = q + 1

Loop

q = 1
If Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 6).Value <> " " Then
Do While Not IsEmpty(Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 6).Value)
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 1).Value = (0 + q + w) & "."
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 2).Value = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 6).Value
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 3).Value = "Стальной выпуск опоры " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 6).Value
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 4).Value = "Сварка"
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 6).Value = "200"
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 7).Value = "0.04"
Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q + w, 9).Value = "годно"
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q + w, 4), Cells(21 + q + w, 5)).Merge
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q + w, 7), Cells(21 + q + w, ).Merge
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q + w, 9), Cells(21 + q + w, 10)).Merge
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q + w, 4), Cells(21 + q + w, 5)).Borders.LineStyle = -xlContinuos
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q + w, 7), Cells(21 + q + w, ).Borders.LineStyle = -xlContinuos
Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q + w, 9), Cells(21 + q + w, 10)).Borders.LineStyle = -xlContinuos

q = q + 1
Loop
End If


End Sub


Имеется вот такой макрос. Суть его работы: Он собирает данные прописанные в столбик на листе "Даные" и строит табличку на листе "Лист14". Сам макрос работает отлично, но он снимает данные только с двух указанных столбиков. Пожалуйста подскажите что нужно сделать, чтобы этот макрос снимал данные не с двух столбиков, а к примеру с пяти разных. Заранее спасибо


P.S. буду благодарен если ответите, как для чайников
 
Код
Sub четырнадцать()
Dim vv As Variant
Dim q, w As Integer
 
w = 0
For Each vv In Array(5, 6, 7)
    If Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 6).Value <> " " Then
        q = 1
        Do While Not IsEmpty(Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, vv).Value)
            w = w + 1
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 1).Value = (0 + q) & "."
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 2).Value = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 3).Value = "Стальной выпуск опоры " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 4).Value = "Сварка"
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 6).Value = "200"
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 7).Value = "0.04"
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 9).Value = "годно"
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 4), Cells(21 + q, 5)).Merge
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 7), Cells(21 + q, 8)).Merge
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 9), Cells(21 + q, 10)).Merge
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 4), Cells(21 + q, 5)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 7), Cells(21 + q, 8)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 9), Cells(21 + q, 10)).Borders.LineStyle = xlContinuous
            q = q + 1
        Loop
    End If
Next
 
End Sub
 
Наверно я не так все вам объяснил. Постараюсь сделать это при помощи скринов. На первом скриншоте то что получается в результате запуска пакроса, на втором скриншоте, исходные данные. На данный момент макрос считывает колонку Е начиная с 7 строки и колонку F начиная с 7 строки и все работает отлично, не зависимо от того сколько будет значения в этих колонках. Но появилась необходимость, чтобы считывались колонки D, K, L, M и N. Заранее спасибо
Изменено: Александр Лапидас - 17.06.2022 05:28:08
 
Код
Sub четырнадцать2()
Dim vv As Variant
Dim q, w As Integer
  
w = 0
For Each vv In Array(5, 6, 7)
    If Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value <> " " Then
        q = 1
        Do While Not IsEmpty(Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value)
            w = w + 1
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 1).Value = (0 + w) & "."
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 2).Value = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 3).Value = "Стальной выпуск опоры " & Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 4).Value = "Сварка"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 6).Value = "200"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 7).Value = "0.04"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 9).Value = "годно"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 4), Cells(21 + w, 5)).Merge
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 7), Cells(21 + w, 8)).Merge
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 9), Cells(21 + w, 10)).Merge
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 4), Cells(21 + w, 5)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 7), Cells(21 + w, 8)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 9), Cells(21 + w, 10)).Borders.LineStyle = xlContinuous
            q = q + 1
        Loop
    End If
Next
  
End Sub

Цитата
написал:
Наверно я не так все вам объяснил. Постараюсь сделать это при помощи скринов.
Правильно: я не так все вам объяснил, я сделал это при помощи скринов.
 
МатросНаЗебре, ну уж вы-то могли бы With Workbooks("исполнительная.xlsm").Sheets("Лист14") сделать хотя бы  :) это уже не говоря о том, что книга везде одна и либо опустить можно, либо также через With  :)
Изменено: Jack Famous - 17.06.2022 11:00:59
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Александр Лапидас написал:
Нужно расширить возможности макроса,
Что можно понять из ТАКОГО названия? Александр Лапидас,  представьте, что это не Ваша тема: прочитав такое название, Вы смогли бы понять задачу?
 
С учётом #5 )
Код
Sub четырнадцать3()
    With Workbooks("исполнительная.xlsm")
        Dim vv As Variant
        Dim q, w As Integer
        Dim arr As Variant
        ReDim arr(1 To 1, 1 To 9)
        arr(1, 4) = "Сварка"
        arr(1, 6) = "200"
        arr(1, 7) = "0.04"
        arr(1, 9) = "годно"
          
        Dim drr As Variant
          
        w = 0
        For Each vv In Array(5, 6, 7)
            
            With .Sheets("Даные")
                q = .Cells(.Rows.Count, vv).End(xlUp).Row
                drr = .Range(.Cells(1, vv), .Cells(q, vv))
            End With
            If UBound(drr, 1) > 6 Then
                If drr(6, 1) <> " " Then
                    q = 1
                    Do While Not IsEmpty(drr(6 + q, 1))
                        w = w + 1
                        arr(1, 1) = (0 + w) & "."
                        arr(1, 2) = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & drr(6 + q, 1)
                        arr(1, 3) = "Стальной выпуск опоры " & drr(6 + q, 1)
                        
                        With .Sheets("Лист14")
                            .Cells(21 + w, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                            .Range(.Cells(21 + w, 4), .Cells(21 + w, 5)).Merge
                            .Range(.Cells(21 + w, 7), .Cells(21 + w, 8)).Merge
                            .Range(.Cells(21 + w, 9), .Cells(21 + w, 10)).Merge
                            .Range(.Cells(21 + w, 4), .Cells(21 + w, 5)).Borders.LineStyle = xlContinuous
                            .Range(.Cells(21 + w, 7), .Cells(21 + w, 8)).Borders.LineStyle = xlContinuous
                            .Range(.Cells(21 + w, 9), .Cells(21 + w, 10)).Borders.LineStyle = xlContinuous
                        End With
                        q = q + 1
                        If 6 + q > UBound(drr, 1) Then Exit Do
                    Loop
                End If
            End If
        Next
    End With
End Sub
 
МатросНаЗебре, ну вот - красота же!  :)  :idea:
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
МатросНаЗебре, Все работает, но это чуть-чуть не то. Как быть если в указанных столбиках нет значений? То есть получается что этот макрос считывает три столбика и заносит значения на Лист14 даже если в нем не было значений.
На Лист14 нужно только те столбики, в которых будут значения.
Изменено: Александр Лапидас - 21.06.2022 00:42:07
Страницы: 1
Наверх