Добрый день, уважаемые специалисты!
Вопрос заключается в следующем, никак не могу реализовать задачу:
-На листе "Сводная" заносятся данные.
- после нажатия кнопки "ДОБАВИТЬ" данные переносятся на другую страницу "Data", где после каждого последующего нажатия кнопки добавляется строка с новыми занесенными данными. Это мне удалось реализовать с помощью макроса с форума(приведен ниже)
1. Но, необходимо переносить не все столбцы, а часть из них (выделенные красным не нужно переносить), и еще в совершенно другом расположении (столбец B нужно перенести, например, в столбец E)
2. Необходимо из одной строки со значениями "значение1", "значение2", "значение3" создать по одной строке с каждым из значений
3. Если "значение4" = пусто, то не писать переносить данную строку
Пример во вложении. Конечный результат, который должен получится в итоге на листе "СВОДНАЯ ТАБЛИЦА"
Вот макрос который я использовал сейчас:
Вопрос заключается в следующем, никак не могу реализовать задачу:
-На листе "Сводная" заносятся данные.
- после нажатия кнопки "ДОБАВИТЬ" данные переносятся на другую страницу "Data", где после каждого последующего нажатия кнопки добавляется строка с новыми занесенными данными. Это мне удалось реализовать с помощью макроса с форума(приведен ниже)
1. Но, необходимо переносить не все столбцы, а часть из них (выделенные красным не нужно переносить), и еще в совершенно другом расположении (столбец B нужно перенести, например, в столбец E)
2. Необходимо из одной строки со значениями "значение1", "значение2", "значение3" создать по одной строке с каждым из значений
3. Если "значение4" = пусто, то не писать переносить данную строку
Пример во вложении. Конечный результат, который должен получится в итоге на листе "СВОДНАЯ ТАБЛИЦА"
Вот макрос который я использовал сейчас:
| Код |
|---|
Sub Procedure_1() Const myStart As Long = 2 Dim shActive As Excel.Worksheet, shTarget As Excel.Worksheet
Dim myFind As Excel.Range
Dim myLastRow As Long
Dim myArray As Variant
Application.ScreenUpdating = False
Set shActive = Sheets("data")
Set shTarget = Sheets("Сводная")
Set myFind = shTarget.Columns("B").Find(What:="?", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False)
If myFind Is Nothing Then
myLastRow = myStart
Else
myLastRow = myFind.Row + 1
End If
shTarget.Rows(myLastRow).Insert Shift:=xlShiftDown, CopyOrigin:=False
shActive.Range("B2:AY2").Copy
shTarget.Cells(myLastRow, "B").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If myLastRow <> myStart Then
Set myFind = shTarget.Range("B" & myStart & ":B" & myLastRow - 1).Find( _
What:=CStr(shActive.Range("B2").Value), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
If Not myFind Is Nothing Then
myArray = Split(CStr(myFind.Value), " ")
If IsNumeric(myArray(UBound(myArray))) Then
shTarget.Cells(myLastRow, "B").Value = _
shTarget.Cells(myLastRow, "B").Value & " " & myArray(UBound(myArray)) + 1
Else
myFind.Value = myFind.Value & " " & "1"
shTarget.Cells(myLastRow, "B").Value = _
shTarget.Cells(myLastRow, "B").Value & " " & 2
End If
End If
End If
Application.ScreenUpdating = TrueEnd Sub |
Изменено: - 18.10.2017 08:51:21
