Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Добавление строк со значениями в Эксель - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавление строк со значениями в Эксель (Макросы/Sub)
Добавление строк со значениями в Эксель
ArtyLight Дата: Четверг, 12.11.2015, 17:38 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
ПРИвет, уже публиковал свой вопрос в теме "Excel", но думаю суда будет вернее.
Из SQL получаю таблицу, которая уже отсортирована как нужно. Вставляю в эксель, и тут начинается ручная работа.
Нужно вставить дополнительный строки между различными типами знаков (предупреждающие, приоритета, запрещающие и т.д., разделение по первому символу столбика "Номер знака по ГОСТ...", и строки с подведением промежуточного итога по типу знака, то есть считать сколько установлено, сколько требуется установить, и всего знаков такого типа.
Возможно это нужно делать на макросе.
Прикрепил файл для примера по вкладкам как надо и как выдает SQL
Помогите кому не сложно, заранее спасибо!
[moder]"уже публиковал" - то есть, Вы сознательно нарушили Правила форума, я Вас правильно понял?
К сообщению приложен файл: 8718149.xlsx (27.6 Kb)


Сообщение отредактировал _Boroda_ - Четверг, 12.11.2015, 18:06
 
Ответить
СообщениеПРИвет, уже публиковал свой вопрос в теме "Excel", но думаю суда будет вернее.
Из SQL получаю таблицу, которая уже отсортирована как нужно. Вставляю в эксель, и тут начинается ручная работа.
Нужно вставить дополнительный строки между различными типами знаков (предупреждающие, приоритета, запрещающие и т.д., разделение по первому символу столбика "Номер знака по ГОСТ...", и строки с подведением промежуточного итога по типу знака, то есть считать сколько установлено, сколько требуется установить, и всего знаков такого типа.
Возможно это нужно делать на макросе.
Прикрепил файл для примера по вкладкам как надо и как выдает SQL
Помогите кому не сложно, заранее спасибо!
[moder]"уже публиковал" - то есть, Вы сознательно нарушили Правила форума, я Вас правильно понял?
Автор - ArtyLight
Дата добавления - 12.11.2015 в 17:38
ArtyLight Дата: Четверг, 12.11.2015, 18:18 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Не знаю как ответить модератору, поэтому отвечу здесь:
"Уже опубликовал" означает, что я первый раз неправильно выбрал Рубрику, и сейчас в той рубрике мой вопрос уже блокирован.
Никаких сознательных нарушений, только бессознательные поступки)))
[moder]Вопрос блокирован потому, что я его только что закрыл. После того, как Вы еще одну тему создали. Читайте Правила форума, там, в п.5, все четко указано.
А нужно было просто написать в том же вопросе просьбу о переносе темы.


Сообщение отредактировал _Boroda_ - Четверг, 12.11.2015, 18:29
 
Ответить
СообщениеНе знаю как ответить модератору, поэтому отвечу здесь:
"Уже опубликовал" означает, что я первый раз неправильно выбрал Рубрику, и сейчас в той рубрике мой вопрос уже блокирован.
Никаких сознательных нарушений, только бессознательные поступки)))
[moder]Вопрос блокирован потому, что я его только что закрыл. После того, как Вы еще одну тему создали. Читайте Правила форума, там, в п.5, все четко указано.
А нужно было просто написать в том же вопросе просьбу о переносе темы.
Автор - ArtyLight
Дата добавления - 12.11.2015 в 18:18
ArtyLight Дата: Четверг, 12.11.2015, 18:38 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Ошибку осознал, обещаю впредь буду действовать только по уставу! Спасибо, за понимание!
 
Ответить
СообщениеОшибку осознал, обещаю впредь буду действовать только по уставу! Спасибо, за понимание!
Автор - ArtyLight
Дата добавления - 12.11.2015 в 18:38
Wasilich Дата: Пятница, 13.11.2015, 18:16 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
Цитата ArtyLight, 12.11.2015 в 17:38, в сообщении № 1
и тут начинается ручная работа.
Неужто каждый день, по полсотни знаков устанавливается? :D
Вот пример, "причесывать" не буду.
К сообщению приложен файл: ArtyLight.xls (87.0 Kb)


Сообщение отредактировал Wasilic - Пятница, 13.11.2015, 18:40
 
Ответить
Сообщение
Цитата ArtyLight, 12.11.2015 в 17:38, в сообщении № 1
и тут начинается ручная работа.
Неужто каждый день, по полсотни знаков устанавливается? :D
Вот пример, "причесывать" не буду.
Автор - Wasilich
Дата добавления - 13.11.2015 в 18:16
Udik Дата: Пятница, 13.11.2015, 19:58 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация: 192 ±
Замечаний: 0% ±

Excel 2016 х 64
Вот если не напутал на ВБА
[vba]
Код


Public Sub strIns()
Dim s As String, s2 As String
Dim i As Integer, j As Integer
Dim arrSNG(1 To 8) As String
Const lOut = "out"
Const lStart = "Ведомость знаков как есть"

arrSNG(1) = "ПРЕДУПРЕЖДАЮЩИЕ ЗНАКИ"
arrSNG(2) = "ЗНАКИ ПРИОРИТЕТА"
arrSNG(3) = "ЗАПРЕЩАЮЩИЕ ЗНАКИ"
arrSNG(4) = ""
arrSNG(5) = "ЗНАКИ ОСОБЫХ ПРЕДПИСАНИЙ"
arrSNG(6) = "ИНФОРМАЦИОННЫЕ ЗНАКИ"
arrSNG(7) = ""
arrSNG(8) = "ЗНАКИ ДОПОЛНИТЕЛЬНОЙ ИНФОРМАЦИИ"

Worksheets(lOut).Cells.Clear 'Очищение
With Worksheets(lStart)

        
Application.DisplayAlerts = False
j = 1
For i = 1 To 101
    .Rows(i & ":" & i).Copy Destination:=Worksheets(lOut).Cells(j, 1)
    s = Trim(.Cells(i, 2).Value)
    s2 = Left(Trim(.Cells(i + 1, 2)), 1)
    If (Left(s, 1) = "2") And (s2 = "1") Then
        With Worksheets(lOut)
        .Cells(j + 1, 1).Font.Name = .Cells(j, 1).Font.Name
        .Cells(j + 4, 1).Font.Size = 14
        .Cells(j + 1, 1) = arrSNG(CInt(s2))
        Range(.Cells(j + 1, 1), .Cells(j + 1, 9)).Merge
        End With
        j = j + 1
    End If
    If s2 = "" Then s2 = "!"
    If (Mid(s, 2, 1) = ".") And (Left(s, 1) <> s2) Then
        With Worksheets(lOut)
            Range(.Cells(j + 1, 1), .Cells(j + 3, 8)).Font.FontStyle = "Bold"
            Range(.Cells(j + 1, 8), .Cells(j + 3, 8)).HorizontalAlignment = xlCenter
            Range(.Cells(j + 1, 1), .Cells(j + 4, 9)).Font.Name = .Cells(j, 1).Font.Name
            
            .Cells(j + 1, 1) = "Итого установлено:"
            Range(.Cells(j + 1, 1), .Cells(j + 1, 7)).Merge
            
            .Cells(j + 2, 1) = "Итого требуется:"
            Range(.Cells(j + 2, 1), .Cells(j + 2, 7)).Merge
            
            .Cells(j + 3, 1) = "Итого:"
            Range(.Cells(j + 3, 1), .Cells(j + 3, 7)).Merge
            
            If (Asc(s2) < 57) And (Asc(s2) > 48) Then
                .Cells(j + 4, 1).Font.Size = 14
                .Cells(j + 4, 1) = arrSNG(CInt(s2))
                Range(.Cells(j + 4, 1), .Cells(j + 4, 9)).Merge
                j = j + 1
            End If
            j = j + 3
           
            End With
    End If
    
    j = j + 1
Next i
With Worksheets(lOut)
    .Select
    Range(.Cells(1, 1), .Cells(j - 1, 9)).Select
    Selection.Borders.Color = vbBlack
    .Cells(1, 1).Select
    For i = 1 To j - 1
        If .Cells(i, 1) Like "*ЗНАКИ*" Then
        s = CStr(i + 1)
        End If
        Select Case .Cells(i, 1)
            Case "Итого установлено:"
             .Cells(i, 8).FormulaLocal = "=СУММ(J" & s & ":J" & i - 1 & ")"
            Case "Итого требуется:"
             .Cells(i, 8).FormulaLocal = "=H" & i + 1 & "-H" & i - 1
            Case "Итого:"
             .Cells(i, 8).FormulaLocal = "=СУММ(H" & s & ":H" & i - 3 & ")"
        End Select
    Next i
    For i = 1 To j - 4
        If .Cells(i, 1) = "Итого установлено:" Then
         .Cells(j - 3, 8).FormulaLocal = .Cells(j - 3, 8).FormulaLocal & "+H" & i
         .Cells(j - 2, 8).FormulaLocal = .Cells(j - 2, 8).FormulaLocal & "+H" & i + 1
         .Cells(j - 1, 8).FormulaLocal = .Cells(j - 1, 8).FormulaLocal & "+H" & i + 2
        End If
    Next i
    .Cells(j - 3, 8).FormulaLocal = "=" & .Cells(j - 3, 8).FormulaLocal
    .Cells(j - 2, 8).FormulaLocal = "=" & .Cells(j - 2, 8).FormulaLocal
    .Cells(j - 1, 8).FormulaLocal = "=" & .Cells(j - 1, 8).FormulaLocal

End With
For i = 1 To 10
    Worksheets(lOut).Columns(i).ColumnWidth = .Columns(i).ColumnWidth
Next i

Application.DisplayAlerts = True
End With
End Sub

[/vba]
К сообщению приложен файл: strIns.xlsm (42.2 Kb)

вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеВот если не напутал на ВБА
[vba]
Код


Public Sub strIns()
Dim s As String, s2 As String
Dim i As Integer, j As Integer
Dim arrSNG(1 To 8) As String
Const lOut = "out"
Const lStart = "Ведомость знаков как есть"

arrSNG(1) = "ПРЕДУПРЕЖДАЮЩИЕ ЗНАКИ"
arrSNG(2) = "ЗНАКИ ПРИОРИТЕТА"
arrSNG(3) = "ЗАПРЕЩАЮЩИЕ ЗНАКИ"
arrSNG(4) = ""
arrSNG(5) = "ЗНАКИ ОСОБЫХ ПРЕДПИСАНИЙ"
arrSNG(6) = "ИНФОРМАЦИОННЫЕ ЗНАКИ"
arrSNG(7) = ""
arrSNG(8) = "ЗНАКИ ДОПОЛНИТЕЛЬНОЙ ИНФОРМАЦИИ"

Worksheets(lOut).Cells.Clear 'Очищение
With Worksheets(lStart)

        
Application.DisplayAlerts = False
j = 1
For i = 1 To 101
    .Rows(i & ":" & i).Copy Destination:=Worksheets(lOut).Cells(j, 1)
    s = Trim(.Cells(i, 2).Value)
    s2 = Left(Trim(.Cells(i + 1, 2)), 1)
    If (Left(s, 1) = "2") And (s2 = "1") Then
        With Worksheets(lOut)
        .Cells(j + 1, 1).Font.Name = .Cells(j, 1).Font.Name
        .Cells(j + 4, 1).Font.Size = 14
        .Cells(j + 1, 1) = arrSNG(CInt(s2))
        Range(.Cells(j + 1, 1), .Cells(j + 1, 9)).Merge
        End With
        j = j + 1
    End If
    If s2 = "" Then s2 = "!"
    If (Mid(s, 2, 1) = ".") And (Left(s, 1) <> s2) Then
        With Worksheets(lOut)
            Range(.Cells(j + 1, 1), .Cells(j + 3, 8)).Font.FontStyle = "Bold"
            Range(.Cells(j + 1, 8), .Cells(j + 3, 8)).HorizontalAlignment = xlCenter
            Range(.Cells(j + 1, 1), .Cells(j + 4, 9)).Font.Name = .Cells(j, 1).Font.Name
            
            .Cells(j + 1, 1) = "Итого установлено:"
            Range(.Cells(j + 1, 1), .Cells(j + 1, 7)).Merge
            
            .Cells(j + 2, 1) = "Итого требуется:"
            Range(.Cells(j + 2, 1), .Cells(j + 2, 7)).Merge
            
            .Cells(j + 3, 1) = "Итого:"
            Range(.Cells(j + 3, 1), .Cells(j + 3, 7)).Merge
            
            If (Asc(s2) < 57) And (Asc(s2) > 48) Then
                .Cells(j + 4, 1).Font.Size = 14
                .Cells(j + 4, 1) = arrSNG(CInt(s2))
                Range(.Cells(j + 4, 1), .Cells(j + 4, 9)).Merge
                j = j + 1
            End If
            j = j + 3
           
            End With
    End If
    
    j = j + 1
Next i
With Worksheets(lOut)
    .Select
    Range(.Cells(1, 1), .Cells(j - 1, 9)).Select
    Selection.Borders.Color = vbBlack
    .Cells(1, 1).Select
    For i = 1 To j - 1
        If .Cells(i, 1) Like "*ЗНАКИ*" Then
        s = CStr(i + 1)
        End If
        Select Case .Cells(i, 1)
            Case "Итого установлено:"
             .Cells(i, 8).FormulaLocal = "=СУММ(J" & s & ":J" & i - 1 & ")"
            Case "Итого требуется:"
             .Cells(i, 8).FormulaLocal = "=H" & i + 1 & "-H" & i - 1
            Case "Итого:"
             .Cells(i, 8).FormulaLocal = "=СУММ(H" & s & ":H" & i - 3 & ")"
        End Select
    Next i
    For i = 1 To j - 4
        If .Cells(i, 1) = "Итого установлено:" Then
         .Cells(j - 3, 8).FormulaLocal = .Cells(j - 3, 8).FormulaLocal & "+H" & i
         .Cells(j - 2, 8).FormulaLocal = .Cells(j - 2, 8).FormulaLocal & "+H" & i + 1
         .Cells(j - 1, 8).FormulaLocal = .Cells(j - 1, 8).FormulaLocal & "+H" & i + 2
        End If
    Next i
    .Cells(j - 3, 8).FormulaLocal = "=" & .Cells(j - 3, 8).FormulaLocal
    .Cells(j - 2, 8).FormulaLocal = "=" & .Cells(j - 2, 8).FormulaLocal
    .Cells(j - 1, 8).FormulaLocal = "=" & .Cells(j - 1, 8).FormulaLocal

End With
For i = 1 To 10
    Worksheets(lOut).Columns(i).ColumnWidth = .Columns(i).ColumnWidth
Next i

Application.DisplayAlerts = True
End With
End Sub

[/vba]
Автор - Udik
Дата добавления - 13.11.2015 в 19:58
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавление строк со значениями в Эксель (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!