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

Вход

Регистрация

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

 

= Мир MS Excel/Преобразование внешнего вида прайс листа (Редизайн) - Мир MS Excel

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

Excel 2013
Добрый день, всем завсегдатым данного форума! Я новичёк в данной тематике, и обращаюсь к Вам с просьбой помочь мне с онной задачей... С VBA столкнулся недавно. И данный код в моём примере (который я вычерпал из недр инета) слишком сложным оказался для меня ( "И собери сам..." у меня не слишком хорошо получилось - выдаёт ошибку в итоге, а в процессе не корректно обрабатывал строки при вставке на второй лист. Хотелось бы визуально и практично внешне обработать прайс лист. Код и фото ожидаемого результата прилагаю в файл-примере... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост
К сообщению приложен файл: 8747976.xls(84Kb)


Сообщение отредактировал ZatX - Понедельник, 15.05.2017, 20:17
 
Ответить
СообщениеДобрый день, всем завсегдатым данного форума! Я новичёк в данной тематике, и обращаюсь к Вам с просьбой помочь мне с онной задачей... С VBA столкнулся недавно. И данный код в моём примере (который я вычерпал из недр инета) слишком сложным оказался для меня ( "И собери сам..." у меня не слишком хорошо получилось - выдаёт ошибку в итоге, а в процессе не корректно обрабатывал строки при вставке на второй лист. Хотелось бы визуально и практично внешне обработать прайс лист. Код и фото ожидаемого результата прилагаю в файл-примере... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост

Автор - ZatX
Дата добавления - 15.05.2017 в 20:09
ZatX Дата: Понедельник, 15.05.2017, 22:36 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Понятно что перелопачивать весь код, это не лёгкая работаю. Но всё же надеюсь что хоть кто-то отзовётся... Вот поковырялся немного в коде, уже ошибку не выдаёт. Но переносит данные как попало((
К сообщению приложен файл: 4400455.xls(90Kb)
 
Ответить
СообщениеПонятно что перелопачивать весь код, это не лёгкая работаю. Но всё же надеюсь что хоть кто-то отзовётся... Вот поковырялся немного в коде, уже ошибку не выдаёт. Но переносит данные как попало((

Автор - ZatX
Дата добавления - 15.05.2017 в 22:36
ZatX Дата: Вторник, 16.05.2017, 03:46 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
[vba]
Код
Option Explicit
Dim CurRow As Integer
Const GroupsCount As Integer = 2
Const DataCount As Integer = 3
Function GetCol(Col As Integer) As String
GetCol = Chr(Asc("A") + Col)
End Function

Function GetCellS(Sheet As String, Col As Integer, Row As Integer) As Range
Set GetCellS = Sheets(Sheet).Range(GetCol(Col) + CStr(Row))
End Function

Function GetCell(Col As Integer, Row As Integer) As Range
Set GetCell = Range(GetCol(Col) + CStr(Row))
End Function
Sub AddHeader(Ty As Integer, Name As String)
With Sheets("result").Range("A" + CStr(CurRow) + ":C" + CStr(CurRow))
.Merge
.Value = Name
.Font.Italic = True
.Font.Name = "Cambria"
.HorizontalAlignment = xlCenter

Select Case Ty
Case 1 ' Òèï
.Font.Bold = True
.Font.Size = 16
.Borders(xlTop).Weight = xlThick
Case 2 ' Ïðîèçâîäèòåëü
.Font.Size = 12
.Borders(xlTop).Weight = xlMedium
End Select
.Borders(xlBottom).Weight = xlMedium ' Ïî óáûâàíèþ: xlThick, xlMedium, xlThin, xlHairline
End With
CurRow = CurRow + 1
End Sub
Sub FormatPrice()
Dim I As Integer ' ñòðîêà â data
CurRow = 0
Dim Groups(1 To GroupsCount) As String
Dim PrGroups(1 To GroupsCount) As String

Sheets("data").Activate
I = 2
Do While True
If GetCell(0, I).Value = "" Then Exit Do
Dim I2 As Integer
For I2 = 1 To GroupsCount
Groups(I2) = GetCell(I2, I)
Next I2
For I2 = 1 To GroupsCount
If Groups(I2) <> PrGroups(I2) Then
CurRow = CurRow + 1
Dim I3 As Integer
For I3 = I2 To GroupsCount
AddHeader I3, Groups(I3)
Next I3
Exit For
End If
Next I2
For I2 = 1 To GroupsCount ' VB íå óìååò êîïèðîâàòü ìàññèâû
PrGroups(I2) = Groups(I2)
Next I2
For I2 = 0 To DataCount - 1
GetCellS("result", I2, CurRow).Value = GetCell(I2, I)
Next I2

I = I + 1
I = I + 1
Loop
Sheets("Result").Activate
Columns.AutoFit
End Sub
[/vba][spoiler]


Сообщение отредактировал ZatX - Вторник, 16.05.2017, 03:57
 
Ответить
Сообщение[vba]
Код
Option Explicit
Dim CurRow As Integer
Const GroupsCount As Integer = 2
Const DataCount As Integer = 3
Function GetCol(Col As Integer) As String
GetCol = Chr(Asc("A") + Col)
End Function

Function GetCellS(Sheet As String, Col As Integer, Row As Integer) As Range
Set GetCellS = Sheets(Sheet).Range(GetCol(Col) + CStr(Row))
End Function

Function GetCell(Col As Integer, Row As Integer) As Range
Set GetCell = Range(GetCol(Col) + CStr(Row))
End Function
Sub AddHeader(Ty As Integer, Name As String)
With Sheets("result").Range("A" + CStr(CurRow) + ":C" + CStr(CurRow))
.Merge
.Value = Name
.Font.Italic = True
.Font.Name = "Cambria"
.HorizontalAlignment = xlCenter

Select Case Ty
Case 1 ' Òèï
.Font.Bold = True
.Font.Size = 16
.Borders(xlTop).Weight = xlThick
Case 2 ' Ïðîèçâîäèòåëü
.Font.Size = 12
.Borders(xlTop).Weight = xlMedium
End Select
.Borders(xlBottom).Weight = xlMedium ' Ïî óáûâàíèþ: xlThick, xlMedium, xlThin, xlHairline
End With
CurRow = CurRow + 1
End Sub
Sub FormatPrice()
Dim I As Integer ' ñòðîêà â data
CurRow = 0
Dim Groups(1 To GroupsCount) As String
Dim PrGroups(1 To GroupsCount) As String

Sheets("data").Activate
I = 2
Do While True
If GetCell(0, I).Value = "" Then Exit Do
Dim I2 As Integer
For I2 = 1 To GroupsCount
Groups(I2) = GetCell(I2, I)
Next I2
For I2 = 1 To GroupsCount
If Groups(I2) <> PrGroups(I2) Then
CurRow = CurRow + 1
Dim I3 As Integer
For I3 = I2 To GroupsCount
AddHeader I3, Groups(I3)
Next I3
Exit For
End If
Next I2
For I2 = 1 To GroupsCount ' VB íå óìååò êîïèðîâàòü ìàññèâû
PrGroups(I2) = Groups(I2)
Next I2
For I2 = 0 To DataCount - 1
GetCellS("result", I2, CurRow).Value = GetCell(I2, I)
Next I2

I = I + 1
I = I + 1
Loop
Sheets("Result").Activate
Columns.AutoFit
End Sub
[/vba][spoiler]

Автор - ZatX
Дата добавления - 16.05.2017 в 03:46
K-SerJC Дата: Вторник, 16.05.2017, 07:25 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 330
Репутация: 48 ±
Замечаний: 0% ±

Excel 2013
а цель в итоге?
надо по графе производитель отсортировать чтобы в результате как на скриншоте было?

типа так?:
К сообщению приложен файл: ZatX.xls(94Kb)


Благими намерениями выстелена дорога в АД.

Сообщение отредактировал K-SerJC - Вторник, 16.05.2017, 08:53
 
Ответить
Сообщениеа цель в итоге?
надо по графе производитель отсортировать чтобы в результате как на скриншоте было?

типа так?:

Автор - K-SerJC
Дата добавления - 16.05.2017 в 07:25
ZatX Дата: Вторник, 16.05.2017, 12:20 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
K-SerJC,Сапасибо большое за отклик. Да,точно как на скриншоте! Можно без этого антуража. Мне нужен сам алгоритм... Тип товара в заголовке, под ним производитель, и внизу то что имеет к ним значение во вотрой строке. В типе товара не всегда только защёлка будет, там ещё и другие наименования есть) В приоритете: иерархия такая.
 
Ответить
СообщениеK-SerJC,Сапасибо большое за отклик. Да,точно как на скриншоте! Можно без этого антуража. Мне нужен сам алгоритм... Тип товара в заголовке, под ним производитель, и внизу то что имеет к ним значение во вотрой строке. В типе товара не всегда только защёлка будет, там ещё и другие наименования есть) В приоритете: иерархия такая.

Автор - ZatX
Дата добавления - 16.05.2017 в 12:20
ZatX Дата: Вторник, 16.05.2017, 13:21 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
K-SerJC, Может хоть так.
К сообщению приложен файл: 9340190.png(60Kb)
 
Ответить
СообщениеK-SerJC, Может хоть так.

Автор - ZatX
Дата добавления - 16.05.2017 в 13:21
and_evg Дата: Вторник, 16.05.2017, 14:41 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 232
Репутация: 41 ±
Замечаний: 0% ±

Excel 2007
ZatX, А может быть так? (Сводной таблицей)
К сообщению приложен файл: 0211297.xls(90Kb)
 
Ответить
СообщениеZatX, А может быть так? (Сводной таблицей)

Автор - and_evg
Дата добавления - 16.05.2017 в 14:41
ZatX Дата: Вторник, 16.05.2017, 16:25 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
and_evg, Спасибо и тебе большое , неравнодушный человек. Хотелось бы довести это до полной автоматизации, так как в дальнейшем планирую прикрутить данный код к своей "машине") И стандартные методы тут не катят( Я не вредный- я только учусь)) Хороший вариант K-SerJC, но хотелось бы привинтить Тип товара на изголовье.
 
Ответить
Сообщениеand_evg, Спасибо и тебе большое , неравнодушный человек. Хотелось бы довести это до полной автоматизации, так как в дальнейшем планирую прикрутить данный код к своей "машине") И стандартные методы тут не катят( Я не вредный- я только учусь)) Хороший вариант K-SerJC, но хотелось бы привинтить Тип товара на изголовье.

Автор - ZatX
Дата добавления - 16.05.2017 в 16:25
K-SerJC Дата: Среда, 17.05.2017, 08:52 | Сообщение № 9
Группа: Проверенные
Ранг: Обитатель
Сообщений: 330
Репутация: 48 ±
Замечаний: 0% ±

Excel 2013
хотелось бы привинтить Тип товара на изголовье.

так?
К сообщению приложен файл: 8074191.xls(53Kb)


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщение
хотелось бы привинтить Тип товара на изголовье.

так?

Автор - K-SerJC
Дата добавления - 17.05.2017 в 08:52
ZatX Дата: Среда, 17.05.2017, 09:56 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Отлично!Огромнейшее СПАСИБО,K-SerJC, Вы очень меня выручили. Всех Вам земных и неземных благ.
 
Ответить
СообщениеОтлично!Огромнейшее СПАСИБО,K-SerJC, Вы очень меня выручили. Всех Вам земных и неземных благ.

Автор - ZatX
Дата добавления - 17.05.2017 в 09:56
ZatX Дата: Среда, 17.05.2017, 09:56 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Спасибо ВСЕМ! Тему можно закрывать.
 
Ответить
СообщениеСпасибо ВСЕМ! Тему можно закрывать.

Автор - ZatX
Дата добавления - 17.05.2017 в 09:56
KuklP Дата: Среда, 17.05.2017, 14:27 | Сообщение № 12
Группа: Проверенные
Ранг: Старожил
Сообщений: 2340
Репутация: 479 ±
Замечаний: 0% ±

2003-2010
Модеры, исправьте пожалуйста эту мерзость в названии:"Приобразование". Бог с ним, что автор букварь скурил: "новичёк... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост" и прочие перлы, но хоть с титульной страницы форума это издевательство можно убрать?


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеМодеры, исправьте пожалуйста эту мерзость в названии:"Приобразование". Бог с ним, что автор букварь скурил: "новичёк... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост" и прочие перлы, но хоть с титульной страницы форума это издевательство можно убрать?

Автор - KuklP
Дата добавления - 17.05.2017 в 14:27
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Преобразование внешнего вида прайс листа (Редизайн) (Макросы/Sub)
Страница 1 из 11
Поиск:

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