Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.79/14: Рейтинг темы: голосов - 14, средняя оценка - 4.79
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
1

Как с одного столбца выдергнуть группы данных и снова сгрупировать в два столбца по порядку

28.02.2013, 03:26. Показов 2663. Ответов 23
Метки нет (Все метки)

Доброго времени суток, профессионалы!!!

В данном направлении я почти 0 на палочке, но всё-же мне необходимо это сделать.
Суть в том, что ежедневно я получаю такую таблицу (количество данных в ней меняется ежедневно) из которой составляется отчет, хотелось бы автоматизировать данный процесс, так как количество строк может достигать и 15000. Что именно надо сделать словами даже и не знаю как объяснить, покажу на примере….
Заранее очень благодарен!
Вложения
Тип файла: xls Excel_2010.xls (37.5 Кб, 17 просмотров)
__________________
Помощь в написании контрольных, курсовых и дипломных работ здесь
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
28.02.2013, 03:26
Ответы с готовыми решениями:

Как из одного столбца вывести значения в два столбца
Не могу никак разобраться, помогите пожалуйста.. Есть две таблицы: Team(id, name, captain,...

Как сделать выбор данных одного столбца из нескольких таблиц, если имя этого столбца везде совпадает?
Подскажите, как сделать выбор данных одного столбца из нескольких таблиц, если имя этого столбца...

Вывод результатов из одной таблицы и одного столбца в два разных столбца
Ребят помогите, измучалась совсем, не знаю как решить. Есть таблица Таблица t2 Id Pid ...

Разбивка данных из одного столбца в два
Добрый день Имеются два потока данных в одном столбце, время и показания прибора. Сохраняются...

23
Заблокирован
28.02.2013, 09:06 2
Cyxapik007, что делает мебель в ячейке H36?
есть список всех сигментов которые повторяются
Т.е. следует при анализе сравнивать не только текст, но и формат ячейки?
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
28.02.2013, 09:53  [ТС] 3
нет, формат не важен
0
Заблокирован
28.02.2013, 09:57 4
Тогда повторю - что делает мебель в ячейке H36?
И Фитнес в H33 тоже как-то не вписывается...
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
28.02.2013, 09:59  [ТС] 5
Н33 и Н36 - опечатка
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
28.02.2013, 10:14  [ТС] 6
вот поправил опечатки
Вложения
Тип файла: xls Excel_2010.xls (40.5 Кб, 13 просмотров)
0
Заблокирован
28.02.2013, 11:42 7
Пробуйте -
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Cyxapik007()
Dim r As Long, a() As String, u As Long, i As Long
For r = 1 To 65536
  If Cells(r, 1) = "" Then Exit For
  If Mid(Cells(r, 1), 1, 1) >= "А" Then
    Cells(r, 2).ClearContents
    For i = 0 To u - 1
      If Cells(r, 1) = a(i) Then Exit For
    Next i
    If i = u Then
      ReDim Preserve a(u)
      a(u) = Cells(r, 1)
      u = u + 1
    End If
  Else
    Cells(r, 2) = i
  End If
Next r
[A:B].Sort key1:=[B1]
For r = 1 To 65536
  If Cells(r, 2) = "" Then Exit For
  Cells(r, 2) = a(Cells(r, 2))
Next r
Columns("B:B").Cut
Columns("A:A").Insert Shift:=xlToRight
End Sub
1
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
28.02.2013, 12:12  [ТС] 8
ООООО дааааа!!!! это оно, спасибо огромное!!!
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
25.03.2013, 08:24  [ТС] 9
привет всем ещё разок!
Моя задачка усложнилась, теперь надо получить не два а 7 столбцов, даже и не знаю реально это или нет....
во вложении два листа, данные это то что я получаю и результат то что должно получиться
Вложения
Тип файла: xls Мониторинг .xls (48.0 Кб, 12 просмотров)
0
Заблокирован
25.03.2013, 08:56 10
Cyxapik007, тут главная проблема - отличить Башкирова Ксения Ивановна (группируете по ФИО, как я понял)
от Негативная кредитная история (чем не ФИО), к примеру?

Если есть гарантия, что ФИО всегда состоит из трех слов, причем только первые буквы заглавные
и ни при каких обстоятельствах подобное не повторится для не ФИО, то задача вполне решаема
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
25.03.2013, 09:03  [ТС] 11
Вообще в листе данные будет промелькивать около 40 фамилий, но мне необходимо только к примеру 8 и их список будет на другом листе, то есть мне неоходимы данные только по конкретным фамилиям

Добавлено через 2 минуты
100 % гарантия, что ФИО будет с заглавных букв, но нет гарантии что из 3-х(((
0
6070 / 1314 / 195
Регистрация: 12.12.2012
Сообщений: 1,023
25.03.2013, 12:21 12
Здравствуйте, Cyxapik007,
Выкладываю вариант решения, определяющий ФИО как последовательность из двух или более слов, начинающихся с заглавной буквы.

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub Peregruppirovka()
   Dim sh As Sheets, ws As Worksheet, rn As Range
   Dim shName As String, ext As String, rowsNum As Long
   Dim v As Variant, f As Boolean
'Блок получения ссылок на первичные данные.
   Set sh = ActiveWorkbook.Worksheets
   On Error GoTo ErrNoData
      Set ws = sh("Данные")
   On Error GoTo 0
   shName = ws.Range("A1")
   Set rn = ws.Range(ws.Range("A2"), ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
   rowsNum = rn.Rows.Count + 1
'Блок создания нового листа и переноса на него данных.
   Set ws = sh.Add(After:=sh(sh.Count))
   On Error GoTo ErrNameAlreadyExists
      ws.Name = shName & ext
   On Error GoTo 0
   Application.ScreenUpdating = False
   With ws
      rn.Copy .Range("B2")
'Блок вычленения ФИО и переноса их в первый столбец.
      For Each rn In .Range(.Range("B2"), .Cells(rowsNum, 2))
         If UBound(Split(rn)) > 0 Then 'Если имеется больше 1 слова...
            f = True
            For Each v In Split(rn)
               If Not (v Like "[А-Я]*") Then 'проверяем, что все они заглавные.
                  f = False   'Если хотя бы одно не с заглавной - это не ФИО.
                  Exit For
               End If
            Next v
            If f Then rn.Cut rn.Offset(, -1) 'В случае успеха - ФИО в 1 столбец.
         End If
      Next rn
'Блок размножения ФИО.
      For Each rn In .Range(.Range("A2"), .Cells(rowsNum, 1))
         If IsEmpty(rn) Then rn = rn.Offset(-1)
      Next rn
'Финальные штрихи.
      .Range("A1:D1") = Array("ФИО", "Код", "Наименование", "Адрес")
      .Range("A1").AutoFilter
      .Columns("A:A").ColumnWidth = 31.29
      .Columns("B:B").ColumnWidth = 20.86
      .Columns("C:C").ColumnWidth = 36.14
      .Columns("D:D").ColumnWidth = 25.71
      .Columns("E:E").ColumnWidth = 7.43
   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Exit Sub
ErrNoData:
   MsgBox "Не могу найти лист с данными.", vbExclamation, "Ошибка"
   Exit Sub
ErrNameAlreadyExists:
   ext = Val(ext) + 1
   Resume
End Sub

С уважением,
Aksima
1
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
26.03.2013, 02:03  [ТС] 13
Aksima, Спасибо!!!
То, что надо, но есть не точность. Не надо чтоб создавался новый лист, а постоянно перезаписывалить данные на одном листе "Результат" и как можно сделать, чтоб остались только те фамилии которые мне нужны
0
Заблокирован
26.03.2013, 08:53 14
Cyxapik007, дайте пример данных с теми фамилии которые мне нужны
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
26.03.2013, 09:30  [ТС] 15
Апострофф, Вот!
Тут я показал как в идеале надо, у меня в зависимости от кол-ва людей отображаются листы и именуются фамилией человека, вот и хотелось бы чтоб данные по каждому человеку находились на его листе
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
26.03.2013, 09:31  [ТС] 16
файл забыл
Вложения
Тип файла: xls Мониторинг .xls (44.5 Кб, 8 просмотров)
0
6070 / 1314 / 195
Регистрация: 12.12.2012
Сообщений: 1,023
26.03.2013, 11:34 17
Здравствуйте, Cyxapik007,
Дописал в конец кода действия по обработке конкретных фамилий.
Вот что получилось теперь:

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Sub PeregruppirovkaV2()
   Dim sh As Sheets, ws As Worksheet, w As Worksheet, rn As Range, rw As Range
   Dim shName As String, rowsNum As Long, v As Variant, f As Boolean
   Dim dict As Object
'Áëîê ïîëó÷åíèÿ ññûëîê íà ïåðâè÷íûå äàííûå.
   Set sh = ActiveWorkbook.Worksheets
   On Error GoTo ErrNoData
      Set ws = sh("Äàííûå")
   On Error GoTo 0
   shName = ws.Range("A1")
   Set rn = ws.Range(ws.Range("A2"), ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
   rowsNum = rn.Rows.Count + 1
'Áëîê ñîçäàíèÿ íîâîãî ëèñòà è ïåðåíîñà íà íåãî äàííûõ.
   Set ws = sh.Add(After:=sh(sh.Count))
'   Application.ScreenUpdating = False
   With ws
      rn.Copy .Range("B2")
'Áëîê âû÷ëåíåíèÿ ÔÈÎ è ïåðåíîñà èõ â ïåðâûé ñòîëáåö.
      For Each rn In .Range(.Range("B2"), .Cells(rowsNum, 2))
         If UBound(Split(rn)) > 0 Then 'Åñëè èìååòñÿ áîëüøå 1 ñëîâà...
            f = True
            For Each v In Split(rn)
               If Not (v Like "[À-ß]*") Then 'ïðîâåðÿåì, ÷òî âñå îíè çàãëàâíûå.
                  f = False   'Åñëè õîòÿ áû îäíî íå ñ çàãëàâíîé - ýòî íå ÔÈÎ.
                  Exit For
               End If
            Next v
            If f Then rn.Cut rn.Offset(, -1) ' ñëó÷àå óñïåõà - ÔÈÎ â 1 ñòîëáåö.
         End If
      Next rn
'Áëîê ðàçìíîæåíèÿ ÔÈÎ.
      For Each rn In .Range(.Range("A2"), .Cells(rowsNum, 1))
         If IsEmpty(rn) Then rn = rn.Offset(-1)
      Next rn
'Åùå íå ôèíàëüíûå øòðèõè...
      .Range("A1:D1") = Array("ÔÈÎ", "Êîä", "Íàèìåíîâàíèå", "Àäðåñ")
   End With
   On Error GoTo ErrNoData
      Set w = sh("Ñïèñîê")
   On Error GoTo 0
'Ñîçäàåì ñïèñîê ÔÈÎ äëÿ îáðàáîòêè.
   Set dict = CreateObject("Scripting.Dictionary")
   For Each rn In w.Range(w.Cells(1), w.Cells(w.Rows.Count, 1).End(xlUp))
      dict.Item(rn.Value) = 0
   Next rn
'Äëÿ êàæäîãî ÔÈÎ ïîëó÷àåì ññûëêó íà ñîîòâåòñòâóþùèé ëèñò (åñëè åãî íåò - ñîçäàåì).
'Çàïîëíÿåì ýòîò ëèñò äàííûìè èç àâòîôèëüòðà.
   For Each v In dict
      ws.Range("A1").AutoFilter 1, v
      With ws.AutoFilter.Range.SpecialCells(12)
         If .Areas.Count < 2 And .Rows.Count < 2 Then
            MsgBox "ÔÈÎ íå íàéäåíî: " & v & " - íåò â äàííûõ." & vbCrLf & _
            "Ïðîïóùåíî.", vbExclamation, "Ïðåäóïðåæäåíèå"
         Else
            f = True
            On Error GoTo ErrNoOutputSheet
               Set w = sh(Split(v)(0))
            On Error GoTo 0
            If f Then
               w.Cells.Clear
            Else
               Columns("A:A").ColumnWidth = 33.29
               Columns("B:B").ColumnWidth = 13.43
               Columns("B:B").NumberFormat = "m/d/yyyy"
               Columns("B:B").HorizontalAlignment = xlLeft
               Columns("C:C").ColumnWidth = 17.86
               Columns("D:D").ColumnWidth = 17.86
               Columns("F:F").NumberFormat = "0.0\%"
               Columns("G:G").NumberFormat = "0.0\%"
            End If
            f = True
            With ws.AutoFilter.Range
               For Each rw In .Rows(2).Resize(.Rows.Count - 1).SpecialCells(12).Rows
                  If f Then
                     Set rn = rw
                     f = False
                  Else
                     Set rn = Application.Union(rn, rw)
                  End If
               Next
            End With
            rn.Copy
            w.Range("A1").PasteSpecial xlPasteValues
         End If
      End With
   Next v
'À âîò òåïåðü ôèíèø!
   Application.DisplayAlerts = False
   ws.Delete
   Application.DisplayAlerts = True
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Exit Sub
ErrNoData:
   MsgBox "Íå ìîãó íàéòè ëèñò ""Äàííûå"" èëè ""Ñïèñîê"".", vbExclamation, "Îøèáêà"
   Exit Sub
ErrNoOutputSheet:
   f = False
   Set w = sh.Add(After:=sh(sh.Count))
   w.Name = Split(v)(0)
   Resume Next
End Sub

С уважением,
Aksima
1
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
27.03.2013, 03:35  [ТС] 18
Aksima, круто все!!!
Правда очень долго, почти 15 минут расчет проходит.
вопрос что нужно изменить, чтоб ссылаться на верное место положения списка и указать точное место копирования по каждой фамилии...(точнее у кождого ФИО будет ячейка "А410" а список находится на листе "РМ" в диапазоне "D1:D20"
0
6070 / 1314 / 195
Регистрация: 12.12.2012
Сообщений: 1,023
27.03.2013, 09:59 19
Доброго дня, Cyxapik007,
Лист списка задается в строке 39:

Visual Basic
1
2
3
   On Error GoTo ErrNoData
      Set w = sh("Список")
   On Error GoTo 0
заменить на:

Visual Basic
1
2
3
   On Error GoTo ErrNoData
      Set w = sh("РМ")
   On Error GoTo 0
Диапазон поиска фамилий задается в строке 43:

Visual Basic
1
2
3
   For Each rn In w.Range(w.Cells(1), w.Cells(w.Rows.Count, 1).End(xlUp))
      dict.Item(rn.Value) = 0
   Next rn
заменить на:

Visual Basic
1
2
3
   For Each rn In w.Range("D1:D20")
      dict.Item(rn.Value) = 0
   Next rn
Верхняя левая ячейка скопированного диапазона задается в строке 83:

Visual Basic
1
w.Range("A1").PasteSpecial xlPasteValues
заменить на:

Visual Basic
1
w.Range("A410").PasteSpecial xlPasteValues
С уважением,
Aksima
0
0 / 0 / 0
Регистрация: 28.02.2013
Сообщений: 20
28.03.2013, 02:18  [ТС] 20
Aksima, в конце ругается на
Visual Basic
1
w.Name = Split(v)(0)
а ещё всё удаляется на листах до ячейки А410 куда вставляется пофамильно(((
просто список фамилий изменный от 1-ой до 20-ти в диапазоне D1 : D20. На данный момент их 8 и на 9-ой выскакивает эта ошибка.
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
28.03.2013, 02:18

В каждой из матриц: A (5 строк, 4 столбца) и В (4 строки, 3 столбца) поменять местами два столбца
В каждой из матриц: A (5 строк, 4 столбца) и В (4 строки, 3 столбца) поменять местами два столбца:...

Сравнить два столбца (не по порядку) и разные строчки вытащить
Есть два столбца с товаром (около 4000 позиций в каждом), они отличаются, и много где. Т.е. я не...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.