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

Вход

Регистрация

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

 

= Мир MS Excel/копирование строки - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование строки (Макросы/Sub)
копирование строки
guli Дата: Понедельник, 10.07.2017, 11:09 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Привет всем. Нужна помощь. Надо с первого листа скопировать строки на второй лист выполнив условия.
К сообщению приложен файл: file1.xls(31Kb)


Сообщение отредактировал guli - Понедельник, 10.07.2017, 11:22
 
Ответить
СообщениеПривет всем. Нужна помощь. Надо с первого листа скопировать строки на второй лист выполнив условия.

Автор - guli
Дата добавления - 10.07.2017 в 11:09
Manyasha Дата: Понедельник, 10.07.2017, 20:12 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2008
Репутация: 837 ±
Замечаний: 0% ±

Excel 2010, 2016
guli, так подойдет?
[vba]
Код
Sub copyRows()
    Dim lr&, lc&, i&, j&, r&, temp$
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    
    r = 2
    With sh1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        sh2.Cells(2, 1).Resize(sh2.Cells(Rows.Count, 1).End(xlUp).Row, lc).ClearContents
        For i = 2 To lr
            For j = 1 To .Cells(i, "g")
                sh2.Cells(r, 1).NumberFormat = "@"
                .Cells(i, 1).Resize(, 7).Copy sh2.Cells(r, 1)
                If j = 1 Then
                    .Cells(i, 8).Resize(, lc - 7).Copy sh2.Cells(r, 10)
                Else
                    temp = Format(CDate(Right(sh2.Cells(r - 1, 3), 5)) + 1 / 24 / 60, "hh:mm")
                    sh2.Cells(r, 3) = Mid(sh2.Cells(r - 1, 3), 1, 20) & temp
                    sh2.Cells(r, 2) = sh2.Cells(r - 1, 2) + 1
                End If
                sh2.Cells(r, 8) = j
                With CreateObject("VBScript.RegExp")
                    .Pattern = "\d+"
                    Set objMatches = .Execute(sh1.Cells(i, 8))
                    If objMatches.Count Then
                        sh2.Cells(r, 9) = CInt(objMatches(0))
                    Else
                        sh2.Cells(r, 9) = 0
                    End If
                End With
                r = r + 1
            Next j
        Next i
    End With
End Sub
[/vba]
К сообщению приложен файл: file1-1.xls(56Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеguli, так подойдет?
[vba]
Код
Sub copyRows()
    Dim lr&, lc&, i&, j&, r&, temp$
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    
    r = 2
    With sh1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        sh2.Cells(2, 1).Resize(sh2.Cells(Rows.Count, 1).End(xlUp).Row, lc).ClearContents
        For i = 2 To lr
            For j = 1 To .Cells(i, "g")
                sh2.Cells(r, 1).NumberFormat = "@"
                .Cells(i, 1).Resize(, 7).Copy sh2.Cells(r, 1)
                If j = 1 Then
                    .Cells(i, 8).Resize(, lc - 7).Copy sh2.Cells(r, 10)
                Else
                    temp = Format(CDate(Right(sh2.Cells(r - 1, 3), 5)) + 1 / 24 / 60, "hh:mm")
                    sh2.Cells(r, 3) = Mid(sh2.Cells(r - 1, 3), 1, 20) & temp
                    sh2.Cells(r, 2) = sh2.Cells(r - 1, 2) + 1
                End If
                sh2.Cells(r, 8) = j
                With CreateObject("VBScript.RegExp")
                    .Pattern = "\d+"
                    Set objMatches = .Execute(sh1.Cells(i, 8))
                    If objMatches.Count Then
                        sh2.Cells(r, 9) = CInt(objMatches(0))
                    Else
                        sh2.Cells(r, 9) = 0
                    End If
                End With
                r = r + 1
            Next j
        Next i
    End With
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 10.07.2017 в 20:12
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование строки (Макросы/Sub)
Страница 1 из 11
Поиск:

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