Нужна помощь в решении такой задачи. Есть база в екселе. Вся информация размещена в трех столбцах (А,B,C). Вот так - http://prntscr.com/et74td В столбце А - указан ID клиента В столбце B - для каждого ID написаны номера полей. Каждое поле имеет определенный номер за которым закреплен тип информации В столбце С - указана сама информация
Для каждого клиента в столбце B всегда находится: под цифрой 2 - его имя под цифрой 5 - его телефон под цифрой 6 - его скайп
Мне нужно написать какой-то макрос или скрипт или программку которая после запуска должна пройтись по всем строкам и в отдельные столбики сохранить только указанную выше информацию.
То есть результат работы должен быть такой - http://prntscr.com/et74xu. То есть нужно сохранить ID клиента и для каждого ID сохранить его имя, телефон и скайп.
Информация может быть написана как буквами, цифрами или спицсимволами и количество символов может быть любым. Задача программы - просто перенести все что есть в ячейке.
Заранее благодарен за помощь
Нужна помощь в решении такой задачи. Есть база в екселе. Вся информация размещена в трех столбцах (А,B,C). Вот так - http://prntscr.com/et74td В столбце А - указан ID клиента В столбце B - для каждого ID написаны номера полей. Каждое поле имеет определенный номер за которым закреплен тип информации В столбце С - указана сама информация
Для каждого клиента в столбце B всегда находится: под цифрой 2 - его имя под цифрой 5 - его телефон под цифрой 6 - его скайп
Мне нужно написать какой-то макрос или скрипт или программку которая после запуска должна пройтись по всем строкам и в отдельные столбики сохранить только указанную выше информацию.
То есть результат работы должен быть такой - http://prntscr.com/et74xu. То есть нужно сохранить ID клиента и для каждого ID сохранить его имя, телефон и скайп.
Информация может быть написана как буквами, цифрами или спицсимволами и количество символов может быть любым. Задача программы - просто перенести все что есть в ячейке.
Dim shSrc As Worksheet, shRes As Worksheet Dim arrSrc(), arrRes() Dim lr As Long, i As Long, r As Long
Application.ScreenUpdating = False
Set shSrc = ActiveSheet Set shRes = Worksheets.Add(After:=shSrc)
shSrc.Sort.SortFields.Clear shSrc.Sort.SortFields.Add Key:=shSrc.Columns("A") shSrc.Sort.SortFields.Add Key:=shSrc.Columns("B") With shSrc.Sort .SetRange shSrc.Columns("A:C") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With
lr = shSrc.Cells(shSrc.Rows.Count, "B").End(xlUp).Row arrSrc() = shSrc.Range("A1:C" & lr).Value ReDim arrRes(1 To UBound(arrSrc), 1 To 4)
r = 1 For i = 1 To UBound(arrSrc) Select Case arrSrc(i, 2) Case 2 arrRes(r, 2) = arrSrc(i, 3) Case 5 arrRes(r, 3) = CStr(arrSrc(i, 3)) Case 6 arrRes(r, 1) = arrSrc(i, 1) arrRes(r, 4) = arrSrc(i, 3) r = r + 1 End Select Next i
Dim shSrc As Worksheet, shRes As Worksheet Dim arrSrc(), arrRes() Dim lr As Long, i As Long, r As Long
Application.ScreenUpdating = False
Set shSrc = ActiveSheet Set shRes = Worksheets.Add(After:=shSrc)
shSrc.Sort.SortFields.Clear shSrc.Sort.SortFields.Add Key:=shSrc.Columns("A") shSrc.Sort.SortFields.Add Key:=shSrc.Columns("B") With shSrc.Sort .SetRange shSrc.Columns("A:C") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With
lr = shSrc.Cells(shSrc.Rows.Count, "B").End(xlUp).Row arrSrc() = shSrc.Range("A1:C" & lr).Value ReDim arrRes(1 To UBound(arrSrc), 1 To 4)
r = 1 For i = 1 To UBound(arrSrc) Select Case arrSrc(i, 2) Case 2 arrRes(r, 2) = arrSrc(i, 3) Case 5 arrRes(r, 3) = CStr(arrSrc(i, 3)) Case 6 arrRes(r, 1) = arrSrc(i, 1) arrRes(r, 4) = arrSrc(i, 3) r = r + 1 End Select Next i
select f1 as ID, max(iif(f2=2,f3,null)) as Имя, max(iif(f2=5,f3,null)) as Телефон, max(iif(f2=6,f3,null)) as Skype FROM `Лист1$` where f1 is not null group by f1
[/vba] плюс макрос для обновления строки подключения в модуле Лист1[vba]
Код
Public WithEvents QT As QueryTable Private Sub qt_BeforeRefresh(Cancel As Boolean) QT.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended " & _ "Properties=""excel 12.0 macro;HDR=no"";Data Source=" & ThisWorkbook.FullName End Sub
[/vba]в ЭтаКнига[vba]
Код
Private Sub Workbook_Open() Set Лист1.QT = ThisWorkbook.Connections("запрос").Ranges(1).ListObject.QueryTable End Sub
[/vba]
Вариант с OLEDB подключением текст запроса [vba]
Код
select f1 as ID, max(iif(f2=2,f3,null)) as Имя, max(iif(f2=5,f3,null)) as Телефон, max(iif(f2=6,f3,null)) as Skype FROM `Лист1$` where f1 is not null group by f1
[/vba] плюс макрос для обновления строки подключения в модуле Лист1[vba]
Код
Public WithEvents QT As QueryTable Private Sub qt_BeforeRefresh(Cancel As Boolean) QT.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended " & _ "Properties=""excel 12.0 macro;HDR=no"";Data Source=" & ThisWorkbook.FullName End Sub
[/vba]в ЭтаКнига[vba]
Код
Private Sub Workbook_Open() Set Лист1.QT = ThisWorkbook.Connections("запрос").Ranges(1).ListObject.QueryTable End Sub
Sub www() Dim s&, i&, x s = 3 x = Cells(1, "A") Application.ScreenUpdating = 0 For i = 1 To Range("B" & Rows.Count).End(xlUp).Row If x = Cells(i, "A") Then If Cells(i, "B") = 2 Then Cells(s, "E") = Cells(i, "A"): Cells(s, "F") = Cells(i, "C") If Cells(i, "B") = 5 Then Cells(s, "G") = Cells(i, "C") If Cells(i, "B") = 6 Then Cells(s, "H") = Cells(i, "C") Else x = Cells(i, "A"): s = s + 1: i = i - 1 End If Next Application.ScreenUpdating = 1 End Sub
[/vba]
Меньше букоф. [vba]
Код
Sub www() Dim s&, i&, x s = 3 x = Cells(1, "A") Application.ScreenUpdating = 0 For i = 1 To Range("B" & Rows.Count).End(xlUp).Row If x = Cells(i, "A") Then If Cells(i, "B") = 2 Then Cells(s, "E") = Cells(i, "A"): Cells(s, "F") = Cells(i, "C") If Cells(i, "B") = 5 Then Cells(s, "G") = Cells(i, "C") If Cells(i, "B") = 6 Then Cells(s, "H") = Cells(i, "C") Else x = Cells(i, "A"): s = s + 1: i = i - 1 End If Next Application.ScreenUpdating = 1 End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
