Добрый день, всем завсегдатым данного форума! Я новичёк в данной тематике, и обращаюсь к Вам с просьбой помочь мне с онной задачей... С VBA столкнулся недавно. И данный код в моём примере (который я вычерпал из недр инета) слишком сложным оказался для меня ( "И собери сам..." у меня не слишком хорошо получилось - выдаёт ошибку в итоге, а в процессе не корректно обрабатывал строки при вставке на второй лист. Хотелось бы визуально и практично внешне обработать прайс лист. Код и фото ожидаемого результата прилагаю в файл-примере... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост
Добрый день, всем завсегдатым данного форума! Я новичёк в данной тематике, и обращаюсь к Вам с просьбой помочь мне с онной задачей... С VBA столкнулся недавно. И данный код в моём примере (который я вычерпал из недр инета) слишком сложным оказался для меня ( "И собери сам..." у меня не слишком хорошо получилось - выдаёт ошибку в итоге, а в процессе не корректно обрабатывал строки при вставке на второй лист. Хотелось бы визуально и практично внешне обработать прайс лист. Код и фото ожидаемого результата прилагаю в файл-примере... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный постZatX
Понятно что перелопачивать весь код, это не лёгкая работаю. Но всё же надеюсь что хоть кто-то отзовётся... Вот поковырялся немного в коде, уже ошибку не выдаёт. Но переносит данные как попало((
Понятно что перелопачивать весь код, это не лёгкая работаю. Но всё же надеюсь что хоть кто-то отзовётся... Вот поковырялся немного в коде, уже ошибку не выдаёт. Но переносит данные как попало((ZatX
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]
[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]
Код
Sub SerJC() Dim wb, shs, shd, f, k, lr, proz As Collection, str, fl, tR, arr wb = ThisWorkbook.Name: shs = "data": shd = "result": lr = Workbooks(wb).Sheets(shs).Cells(Rows.Count, 1).End(xlUp).Row Set proz = New Collection For f = 2 To lr str = Workbooks(wb).Sheets(shs).Cells(f, 5).Value If proz.Count < 1 Then proz.Add str fl = 0 For k = 1 To proz.Count If proz.Item(k) = str Then fl = 1 Next k If fl = 0 Then proz.Add str Next f tR = 1 For k = 1 To proz.Count Workbooks(wb).Sheets(shd).Select str = "A" & tR & ":C" & tR Workbooks(wb).Sheets(shd).Range(str).Select Selection.MergeCells = True Selection.Value = proz.Item(k): tR = tR + 1 For f = 1 To lr If Workbooks(wb).Sheets(shs).Cells(f, 5).Value = proz.Item(k) Then str = "A" & f & ":C" & f: arr = Workbooks(wb).Sheets(shs).Range(str).Value str = "A" & tR & ":C" & tR: Workbooks(wb).Sheets(shd).Range(str).Value = arr: tR = tR + 1 End If Next f Next k Workbooks(wb).Sheets(shd).Activate Columns.AutoFit End Sub
[/vba]
а цель в итоге? надо по графе производитель отсортировать чтобы в результате как на скриншоте было?
типа так?:
[vba]
Код
Sub SerJC() Dim wb, shs, shd, f, k, lr, proz As Collection, str, fl, tR, arr wb = ThisWorkbook.Name: shs = "data": shd = "result": lr = Workbooks(wb).Sheets(shs).Cells(Rows.Count, 1).End(xlUp).Row Set proz = New Collection For f = 2 To lr str = Workbooks(wb).Sheets(shs).Cells(f, 5).Value If proz.Count < 1 Then proz.Add str fl = 0 For k = 1 To proz.Count If proz.Item(k) = str Then fl = 1 Next k If fl = 0 Then proz.Add str Next f tR = 1 For k = 1 To proz.Count Workbooks(wb).Sheets(shd).Select str = "A" & tR & ":C" & tR Workbooks(wb).Sheets(shd).Range(str).Select Selection.MergeCells = True Selection.Value = proz.Item(k): tR = tR + 1 For f = 1 To lr If Workbooks(wb).Sheets(shs).Cells(f, 5).Value = proz.Item(k) Then str = "A" & f & ":C" & f: arr = Workbooks(wb).Sheets(shs).Range(str).Value str = "A" & tR & ":C" & tR: Workbooks(wb).Sheets(shd).Range(str).Value = arr: tR = tR + 1 End If Next f Next k Workbooks(wb).Sheets(shd).Activate Columns.AutoFit End Sub
K-SerJC,Сапасибо большое за отклик. Да,точно как на скриншоте! Можно без этого антуража. Мне нужен сам алгоритм... Тип товара в заголовке, под ним производитель, и внизу то что имеет к ним значение во вотрой строке. В типе товара не всегда только защёлка будет, там ещё и другие наименования есть) В приоритете: иерархия такая.
K-SerJC,Сапасибо большое за отклик. Да,точно как на скриншоте! Можно без этого антуража. Мне нужен сам алгоритм... Тип товара в заголовке, под ним производитель, и внизу то что имеет к ним значение во вотрой строке. В типе товара не всегда только защёлка будет, там ещё и другие наименования есть) В приоритете: иерархия такая.ZatX
and_evg, Спасибо и тебе большое , неравнодушный человек. Хотелось бы довести это до полной автоматизации, так как в дальнейшем планирую прикрутить данный код к своей "машине") И стандартные методы тут не катят( Я не вредный- я только учусь)) Хороший вариант K-SerJC, но хотелось бы привинтить Тип товара на изголовье.
and_evg, Спасибо и тебе большое , неравнодушный человек. Хотелось бы довести это до полной автоматизации, так как в дальнейшем планирую прикрутить данный код к своей "машине") И стандартные методы тут не катят( Я не вредный- я только учусь)) Хороший вариант K-SerJC, но хотелось бы привинтить Тип товара на изголовье.ZatX
Sub SerJC() Dim wb, shs, shd, t, f, k, lr, det As Collection, proz As Collection, str, strD, fl, tR, arr, пусто wb = ThisWorkbook.Name: shs = "data": shd = "result": lr = Workbooks(wb).Sheets(shs).Cells(Rows.Count, 1).End(xlUp).Row Set proz = New Collection Set det = New Collection For f = 2 To lr str = Workbooks(wb).Sheets(shs).Cells(f, 5).Value strD = Workbooks(wb).Sheets(shs).Cells(f, 4).Value If proz.Count < 1 Then proz.Add str If det.Count < 1 Then det.Add strD fl = 0 For k = 1 To proz.Count If proz.Item(k) = str Then fl = 1 Next k If fl = 0 Then proz.Add str fl = 0 For k = 1 To det.Count If det.Item(k) = strD Then fl = 1 Next k If fl = 0 Then det.Add strD Next f tR = 1 Workbooks(wb).Sheets(shd).Select Workbooks(wb).Sheets(shd).Columns("A:C").Select Selection.Clear For t = 1 To det.Count str = "A" & tR & ":C" & tR Workbooks(wb).Sheets(shd).Range(str).Select With Selection .MergeCells = True .Value = det.Item(t) .Font.Bold = True .Interior.Color = 65535 .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With tR = tR + 1
For k = 1 To proz.Count str = "A" & tR & ":C" & tR Workbooks(wb).Sheets(shd).Range(str).Select With Selection .MergeCells = True .Value = proz.Item(k) .Font.Bold = True .Interior.Color = 15773696 .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With пусто = tR: tR = tR + 1
For f = 1 To lr If Workbooks(wb).Sheets(shs).Cells(f, 5).Value = proz.Item(k) And Workbooks(wb).Sheets(shs).Cells(f, 4).Value = det.Item(t) Then str = "A" & f & ":C" & f: arr = Workbooks(wb).Sheets(shs).Range(str).Value str = "A" & tR & ":C" & tR: Workbooks(wb).Sheets(shd).Range(str).Value = arr: tR = tR + 1 End If Next f If tR = пусто + 1 Then tR = пусто Selection.MergeCells = False Selection.Clear End If Next k Next t Workbooks(wb).Sheets(shd).Activate Columns.AutoFit End Sub
Sub SerJC() Dim wb, shs, shd, t, f, k, lr, det As Collection, proz As Collection, str, strD, fl, tR, arr, пусто wb = ThisWorkbook.Name: shs = "data": shd = "result": lr = Workbooks(wb).Sheets(shs).Cells(Rows.Count, 1).End(xlUp).Row Set proz = New Collection Set det = New Collection For f = 2 To lr str = Workbooks(wb).Sheets(shs).Cells(f, 5).Value strD = Workbooks(wb).Sheets(shs).Cells(f, 4).Value If proz.Count < 1 Then proz.Add str If det.Count < 1 Then det.Add strD fl = 0 For k = 1 To proz.Count If proz.Item(k) = str Then fl = 1 Next k If fl = 0 Then proz.Add str fl = 0 For k = 1 To det.Count If det.Item(k) = strD Then fl = 1 Next k If fl = 0 Then det.Add strD Next f tR = 1 Workbooks(wb).Sheets(shd).Select Workbooks(wb).Sheets(shd).Columns("A:C").Select Selection.Clear For t = 1 To det.Count str = "A" & tR & ":C" & tR Workbooks(wb).Sheets(shd).Range(str).Select With Selection .MergeCells = True .Value = det.Item(t) .Font.Bold = True .Interior.Color = 65535 .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With tR = tR + 1
For k = 1 To proz.Count str = "A" & tR & ":C" & tR Workbooks(wb).Sheets(shd).Range(str).Select With Selection .MergeCells = True .Value = proz.Item(k) .Font.Bold = True .Interior.Color = 15773696 .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With пусто = tR: tR = tR + 1
For f = 1 To lr If Workbooks(wb).Sheets(shs).Cells(f, 5).Value = proz.Item(k) And Workbooks(wb).Sheets(shs).Cells(f, 4).Value = det.Item(t) Then str = "A" & f & ":C" & f: arr = Workbooks(wb).Sheets(shs).Range(str).Value str = "A" & tR & ":C" & tR: Workbooks(wb).Sheets(shd).Range(str).Value = arr: tR = tR + 1 End If Next f If tR = пусто + 1 Then tR = пусто Selection.MergeCells = False Selection.Clear End If Next k Next t Workbooks(wb).Sheets(shd).Activate Columns.AutoFit End Sub
Модеры, исправьте пожалуйста эту мерзость в названии:"Приобразование". Бог с ним, что автор букварь скурил: "новичёк... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост" и прочие перлы, но хоть с титульной страницы форума это издевательство можно убрать?
Модеры, исправьте пожалуйста эту мерзость в названии:"Приобразование". Бог с ним, что автор букварь скурил: "новичёк... Заранее: Сапсибо Всем тем, что хоть кто-то обратил внимание на данный пост" и прочие перлы, но хоть с титульной страницы форума это издевательство можно убрать?KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
