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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование данных в один лист с удаление дубликатов - Мир MS Excel

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

Excel 2013
Уважаемые знатоки VBA есть таблица учета выездов Мобильных ДГА и раз в месяц необходимо собрать данные в один лист
Я попробовал написать Макрос но он у меня собирает их не учитывая повторяющих данных (объектов)
А мне нужно чтобы данные первых 8 столбцов не повторялись а значений остальных столбцов были на против.
Модуль макроса 4-тый
Я скрыл столбцы не относящийся к этому макросу
Я новичок в VBA может что то не догоняю еще вот и мучаюсь ломая голову :-)
Пример Кода
[vba]
Код
Sub ts()
Dim c As Range, LastRow1 As Integer, LastRow2 As Integer, s As Integer, rz As Integer

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 2 To Sheets.Count

With Sheets(i)
Dim A As Integer, B As Integer
LastRow2 = Sheets(1).Cells(Rows.Count, 11).End(xlUp).Row
LastRow1 = .Cells(3, 1).End(xlDown).Row

s = i
If s = 2 Then
s = 0
ElseIf i = 3 Then
s = 8
Else
s = (i - 2) * 7 + 1
End If
Sheets(i).Range("A3:H" & LastRow1 - 1).Copy Sheets(1).Cells(LastRow2 + 1, 11)
For Each c In .Range(.[I3], .Cells(LastRow1, "V"))
A = Hour(.Cells(c.Row, c.Column))
B = Hour(.Cells(c.Row, c.Column + 1))
If c.Value = "" Then
R = ""
End If
If B - A > 12 Then
R = 2
ElseIf Not c.Value = "" Then
R = 1
End If

Select Case c.Column
Case 9: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 18) = R: 'Sheets(1).Cells(LastRow + 2, s+18) = Sheets(1).Cells(1, c.Column).Value
Case 11: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 19) = R: 'Sheets(1).Cells(LastRow2 - 2, s+19) = Sheets(1).Cells(1, c.Column).Value
Case 13: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 20) = R: 'Sheets(1).Cells(LastRow2 - 2, s+20) = Sheets(1).Cells(1, c.Column).Value
Case 15: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 21) = R: 'Sheets(1).Cells(LastRow2 - 2, s+21) = Sheets(1).Cells(1, c.Column).Value
Case 17: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 22) = R: 'Sheets(1).Cells(LastRow2 - 2, s+22) = Sheets(1).Cells(1, c.Column).Value
Case 19: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 23) = R: 'Sheets(1).Cells(LastRow2 - 2, s+23) = Sheets(1).Cells(1, c.Column).Value
Case 21: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 24) = R: 'Sheets(1).Cells(LastRow2 - 2, s+24) = Sheets(1).Cells(1, c.Column).Value

End Select

Next c

End With
Next i
End Sub
[/vba]
[moder]Нарушение п.3 Правил форума в части тегов. Исправил.[/moder]
К сообщению приложен файл: Mobile_DG-macro.xlsm(46Kb)


Сообщение отредактировал _Boroda_ - Пятница, 05.02.2016, 09:16
 
Ответить
СообщениеУважаемые знатоки VBA есть таблица учета выездов Мобильных ДГА и раз в месяц необходимо собрать данные в один лист
Я попробовал написать Макрос но он у меня собирает их не учитывая повторяющих данных (объектов)
А мне нужно чтобы данные первых 8 столбцов не повторялись а значений остальных столбцов были на против.
Модуль макроса 4-тый
Я скрыл столбцы не относящийся к этому макросу
Я новичок в VBA может что то не догоняю еще вот и мучаюсь ломая голову :-)
Пример Кода
[vba]
Код
Sub ts()
Dim c As Range, LastRow1 As Integer, LastRow2 As Integer, s As Integer, rz As Integer

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 2 To Sheets.Count

With Sheets(i)
Dim A As Integer, B As Integer
LastRow2 = Sheets(1).Cells(Rows.Count, 11).End(xlUp).Row
LastRow1 = .Cells(3, 1).End(xlDown).Row

s = i
If s = 2 Then
s = 0
ElseIf i = 3 Then
s = 8
Else
s = (i - 2) * 7 + 1
End If
Sheets(i).Range("A3:H" & LastRow1 - 1).Copy Sheets(1).Cells(LastRow2 + 1, 11)
For Each c In .Range(.[I3], .Cells(LastRow1, "V"))
A = Hour(.Cells(c.Row, c.Column))
B = Hour(.Cells(c.Row, c.Column + 1))
If c.Value = "" Then
R = ""
End If
If B - A > 12 Then
R = 2
ElseIf Not c.Value = "" Then
R = 1
End If

Select Case c.Column
Case 9: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 18) = R: 'Sheets(1).Cells(LastRow + 2, s+18) = Sheets(1).Cells(1, c.Column).Value
Case 11: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 19) = R: 'Sheets(1).Cells(LastRow2 - 2, s+19) = Sheets(1).Cells(1, c.Column).Value
Case 13: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 20) = R: 'Sheets(1).Cells(LastRow2 - 2, s+20) = Sheets(1).Cells(1, c.Column).Value
Case 15: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 21) = R: 'Sheets(1).Cells(LastRow2 - 2, s+21) = Sheets(1).Cells(1, c.Column).Value
Case 17: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 22) = R: 'Sheets(1).Cells(LastRow2 - 2, s+22) = Sheets(1).Cells(1, c.Column).Value
Case 19: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 23) = R: 'Sheets(1).Cells(LastRow2 - 2, s+23) = Sheets(1).Cells(1, c.Column).Value
Case 21: Sheets(1).Cells(c.Row + LastRow2 - 2, s + 24) = R: 'Sheets(1).Cells(LastRow2 - 2, s+24) = Sheets(1).Cells(1, c.Column).Value

End Select

Next c

End With
Next i
End Sub
[/vba]
[moder]Нарушение п.3 Правил форума в части тегов. Исправил.[/moder]

Автор - n-ergash
Дата добавления - 05.02.2016 в 08:06
n-ergash Дата: Понедельник, 08.02.2016, 14:29 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Сам нашел решение тема закрыта
Если у кого такая же ситуация файл выложил на другом ресурсе:
http://www.planetaexcel.ru/forum....2%D0%B8
 
Ответить
СообщениеСам нашел решение тема закрыта
Если у кого такая же ситуация файл выложил на другом ресурсе:
http://www.planetaexcel.ru/forum....2%D0%B8

Автор - n-ergash
Дата добавления - 08.02.2016 в 14:29
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование данных в один лист с удаление дубликатов (Макросы/Sub)
Страница 1 из 11
Поиск:

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