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

Вход

Регистрация

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

 

= Мир MS Excel/Свод данных при помощи макроса - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Свод данных при помощи макроса (Макросы/Sub)
Свод данных при помощи макроса
ILYA_SERGEEVICH_1987 Дата: Суббота, 06.02.2021, 00:54 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Доброго времени суток подскажите п-та решение, начал писать макрос на автоматическое составление необходимого отчёта, возникли трудности как сделать так что бы данные переносились в другую книгу созданную макросом, по принципу ВПР. Привожу то что уже написал, если у кого-то есть решение как можно сделать поделитесь п-та. Прошу строго не судить за очень корявый код, макрос первый в моей жизни который я пытаюсь сделать сам.

Сам макрос

[vba]
Код
Sub аналитика()

Dim New_Wb As Workbook
Set New_Wb = Workbooks.Add
Dim Date1 As String
Date1 = Date
New_Wb.Activate
MsgBox Date1

ActiveWorkbook.SaveAs Filename:="E:\" & Date1 & ".xls"

Application.Goto Workbooks("Книга1.xlsm").Sheets("Лист1").Range("C7")

Dim Range1
Set Range1 = Workbooks("Книга1.xlsm").Sheets("Лист1").Range("C1:C1000")

Dim spisok1 As Integer
spisok1 = Application.WorksheetFunction.CountIf(Range1, 1)

MsgBox spisok1

Dim spisok2 As Integer
spisok2 = Application.WorksheetFunction.CountIf(Range1, 2)

MsgBox spisok2

Application.Goto Workbooks(Date1 & ".xls").Sheets("Лист1").Range("A1")

Range("C3").Select
ActiveCell.FormulaR1C1 = "Сменно-суточное задание на пилоотрезные станки"
Range("C4").Select
ActiveCell.FormulaR1C1 = "Дата"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Утверждаю"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Наименование оборудования"
Range("A7").Select
Columns("A:A").ColumnWidth = 18
Range("B6").Select
Columns("B:B").ColumnWidth = 38.89
ActiveCell.FormulaR1C1 = "шифр"
Range("C6").Select
ActiveCell.FormulaR1C1 = "Количество"
Range("D6").Select
ActiveCell.FormulaR1C1 = "операция"
Range("D7").Select

Range(Cells(7, 1), Cells(7 + spisok1, 1)).Select
Range(Cells(7, 1), Cells(7 + spisok1, 1)).Merge (0)

Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)).Select
Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)).Merge (0)

End Sub
[/vba]
К сообщению приложен файл: 06.02.2021.xlsx (10.3 Kb) · 0756389.xlsm (20.9 Kb)


Сообщение отредактировал ILYA_SERGEEVICH_1987 - Суббота, 06.02.2021, 00:56
 
Ответить
СообщениеДоброго времени суток подскажите п-та решение, начал писать макрос на автоматическое составление необходимого отчёта, возникли трудности как сделать так что бы данные переносились в другую книгу созданную макросом, по принципу ВПР. Привожу то что уже написал, если у кого-то есть решение как можно сделать поделитесь п-та. Прошу строго не судить за очень корявый код, макрос первый в моей жизни который я пытаюсь сделать сам.

Сам макрос

[vba]
Код
Sub аналитика()

Dim New_Wb As Workbook
Set New_Wb = Workbooks.Add
Dim Date1 As String
Date1 = Date
New_Wb.Activate
MsgBox Date1

ActiveWorkbook.SaveAs Filename:="E:\" & Date1 & ".xls"

Application.Goto Workbooks("Книга1.xlsm").Sheets("Лист1").Range("C7")

Dim Range1
Set Range1 = Workbooks("Книга1.xlsm").Sheets("Лист1").Range("C1:C1000")

Dim spisok1 As Integer
spisok1 = Application.WorksheetFunction.CountIf(Range1, 1)

MsgBox spisok1

Dim spisok2 As Integer
spisok2 = Application.WorksheetFunction.CountIf(Range1, 2)

MsgBox spisok2

Application.Goto Workbooks(Date1 & ".xls").Sheets("Лист1").Range("A1")

Range("C3").Select
ActiveCell.FormulaR1C1 = "Сменно-суточное задание на пилоотрезные станки"
Range("C4").Select
ActiveCell.FormulaR1C1 = "Дата"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Утверждаю"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Наименование оборудования"
Range("A7").Select
Columns("A:A").ColumnWidth = 18
Range("B6").Select
Columns("B:B").ColumnWidth = 38.89
ActiveCell.FormulaR1C1 = "шифр"
Range("C6").Select
ActiveCell.FormulaR1C1 = "Количество"
Range("D6").Select
ActiveCell.FormulaR1C1 = "операция"
Range("D7").Select

Range(Cells(7, 1), Cells(7 + spisok1, 1)).Select
Range(Cells(7, 1), Cells(7 + spisok1, 1)).Merge (0)

Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)).Select
Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)).Merge (0)

End Sub
[/vba]

Автор - ILYA_SERGEEVICH_1987
Дата добавления - 06.02.2021 в 00:54
Pelena Дата: Суббота, 06.02.2021, 11:10 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19165
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
ILYA_SERGEEVICH_1987, оформите код тегами с помощью кнопки # в режиме правки поста


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеILYA_SERGEEVICH_1987, оформите код тегами с помощью кнопки # в режиме правки поста

Автор - Pelena
Дата добавления - 06.02.2021 в 11:10
Апострофф Дата: Суббота, 06.02.2021, 12:24 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 444
Репутация: 122 ±
Замечаний: 0% ±

Excel 1997
После выполнения рекомендации от Pelena попробуйте заменить

Цитата ILYA_SERGEEVICH_1987, 06.02.2021 в 00:54, в сообщении № 1 ()
Range("C3").Select
ActiveCell.FormulaR1C1 = "Сменно-суточное задание на пилоотрезные станки"

на
[vba]
Код
[C3]="Сменно-суточное задание на пилоотрезные станки"
[/vba]
и т.д. по тексту.
Насколько вопрос упростится?
Про "Новая книга"?
[vba]
Код
dim new_book as workbook
set new_book=workbookS.ADD
[/vba]
 
Ответить
СообщениеПосле выполнения рекомендации от Pelena попробуйте заменить

Цитата ILYA_SERGEEVICH_1987, 06.02.2021 в 00:54, в сообщении № 1 ()
Range("C3").Select
ActiveCell.FormulaR1C1 = "Сменно-суточное задание на пилоотрезные станки"

на
[vba]
Код
[C3]="Сменно-суточное задание на пилоотрезные станки"
[/vba]
и т.д. по тексту.
Насколько вопрос упростится?
Про "Новая книга"?
[vba]
Код
dim new_book as workbook
set new_book=workbookS.ADD
[/vba]

Автор - Апострофф
Дата добавления - 06.02.2021 в 12:24
ILYA_SERGEEVICH_1987 Дата: Понедельник, 08.02.2021, 20:22 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Оптимизация кода это конечно очень да же хорошо, и это безусловно будет сделано после того в нем прибудет 100% функционал. Сейчас необходимо добиться именно этого. На данном этапе необходимо решить проблему по вводу данных из исходной книги в которой написан макрос во вновь создаваемую причём там где стоит метка "1" будет относится к первому блоку, а там где стоит "2" ко второму блоку. Начал уже сам придумывать, но пока не совсем успешно. Написал нижеприведённую вещь в дополнение к макросу из первого поста, но как то он не работает.

[vba]
Код


Workbooks("Книга1.xlsm").Sheets("Лист1").Activate ' Активирует лист книги

Dim a As Variant, i As Long, b As Variant, k As Long ' Описывает переменные
  a = Лист1.Range("A3:D1000") ' Задаёт параметры массива
    For i = 1 To 1000
      If a(3, i) = 1 Then ' Выполнят поиск "1" в 3 столбике вышеописанного массива
      b = a(1, i) ' Если сбывается условие то присваивает переменной "b" значение из 1 столбика  
      End If
    Next
    
Workbooks(Date1 & ".xls").Sheets("Лист1").Activate
  Лист2.Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)) = b 'присваивает значение "b" соответствующим ячейкам

[/vba]

Все это не совсем сказать что работает но думаю что принцип понятен. Подскажите как можно реализовать данный алгоритм.

[/spoiler]


Сообщение отредактировал ILYA_SERGEEVICH_1987 - Понедельник, 08.02.2021, 20:22
 
Ответить
СообщениеОптимизация кода это конечно очень да же хорошо, и это безусловно будет сделано после того в нем прибудет 100% функционал. Сейчас необходимо добиться именно этого. На данном этапе необходимо решить проблему по вводу данных из исходной книги в которой написан макрос во вновь создаваемую причём там где стоит метка "1" будет относится к первому блоку, а там где стоит "2" ко второму блоку. Начал уже сам придумывать, но пока не совсем успешно. Написал нижеприведённую вещь в дополнение к макросу из первого поста, но как то он не работает.

[vba]
Код


Workbooks("Книга1.xlsm").Sheets("Лист1").Activate ' Активирует лист книги

Dim a As Variant, i As Long, b As Variant, k As Long ' Описывает переменные
  a = Лист1.Range("A3:D1000") ' Задаёт параметры массива
    For i = 1 To 1000
      If a(3, i) = 1 Then ' Выполнят поиск "1" в 3 столбике вышеописанного массива
      b = a(1, i) ' Если сбывается условие то присваивает переменной "b" значение из 1 столбика  
      End If
    Next
    
Workbooks(Date1 & ".xls").Sheets("Лист1").Activate
  Лист2.Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)) = b 'присваивает значение "b" соответствующим ячейкам

[/vba]

Все это не совсем сказать что работает но думаю что принцип понятен. Подскажите как можно реализовать данный алгоритм.

[/spoiler]

Автор - ILYA_SERGEEVICH_1987
Дата добавления - 08.02.2021 в 20:22
RAN Дата: Понедельник, 08.02.2021, 22:27 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Надо помяукать :D
[vba]
Код
Sub Мяу()
    Dim ar, a()
    Dim oDic As Object, d As Object
    Dim i&, x&
    Set oDic = CreateObject("Scripting.Dictionary")
    ar = ThisWorkbook.Sheets(1).Range("C4").CurrentRegion.Value
    For i = 1 To UBound(ar)
        If Len(ar(i, 3)) Then
            If oDic.exists(ar(i, 3)) Then
                Set d = oDic.Item(ar(i, 3))
                ReDim a(1)
                a(0) = ar(i, 2)
                a(1) = ar(i, 4)
                d.Item(d.Count) = a
                Set oDic.Item(ar(i, 3)) = d
            Else
                Set d = CreateObject("Scripting.Dictionary")
                ReDim a(1)
                a(0) = ar(i, 2)
                a(1) = ar(i, 4)
                d.Item(d.Count) = a
                Set oDic.Item(ar(i, 3)) = d
            End If
        End If
    Next
    With Workbooks.Add(1)
        With .Sheets(1)
            .Range("C3").Value = "Сменно-суточное задание на пилоотрезные станки"
            .Range("C4").Value = "Дата"
            .Range("H1").Value = "Утверждаю"
            .Range("A6").Value = "Наименование оборудования"
            .Columns("A").ColumnWidth = 18
            .Columns("B").ColumnWidth = 38.89
            .Range("B6").Value = "шифр"
            .Range("C6").Value = "Количество"
            .Range("D6").Value = "операция"
            For i = 1 To oDic.Count
                x = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                x = x - (x > 7)
                .Cells(x, 1).Resize(oDic(i).Count + 1).Merge
                .Cells(x, 2).Resize(oDic(i).Count, 2).Value = Application.Transpose(Application.Transpose(oDic(i).Items))
            Next
        End With
        .SaveAs Filename:="D:\" & Format(Date, "dd_mm_yyyy") & ".xlsx", FileFormat:=51
    End With
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Понедельник, 08.02.2021, 22:35
 
Ответить
СообщениеНадо помяукать :D
[vba]
Код
Sub Мяу()
    Dim ar, a()
    Dim oDic As Object, d As Object
    Dim i&, x&
    Set oDic = CreateObject("Scripting.Dictionary")
    ar = ThisWorkbook.Sheets(1).Range("C4").CurrentRegion.Value
    For i = 1 To UBound(ar)
        If Len(ar(i, 3)) Then
            If oDic.exists(ar(i, 3)) Then
                Set d = oDic.Item(ar(i, 3))
                ReDim a(1)
                a(0) = ar(i, 2)
                a(1) = ar(i, 4)
                d.Item(d.Count) = a
                Set oDic.Item(ar(i, 3)) = d
            Else
                Set d = CreateObject("Scripting.Dictionary")
                ReDim a(1)
                a(0) = ar(i, 2)
                a(1) = ar(i, 4)
                d.Item(d.Count) = a
                Set oDic.Item(ar(i, 3)) = d
            End If
        End If
    Next
    With Workbooks.Add(1)
        With .Sheets(1)
            .Range("C3").Value = "Сменно-суточное задание на пилоотрезные станки"
            .Range("C4").Value = "Дата"
            .Range("H1").Value = "Утверждаю"
            .Range("A6").Value = "Наименование оборудования"
            .Columns("A").ColumnWidth = 18
            .Columns("B").ColumnWidth = 38.89
            .Range("B6").Value = "шифр"
            .Range("C6").Value = "Количество"
            .Range("D6").Value = "операция"
            For i = 1 To oDic.Count
                x = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                x = x - (x > 7)
                .Cells(x, 1).Resize(oDic(i).Count + 1).Merge
                .Cells(x, 2).Resize(oDic(i).Count, 2).Value = Application.Transpose(Application.Transpose(oDic(i).Items))
            Next
        End With
        .SaveAs Filename:="D:\" & Format(Date, "dd_mm_yyyy") & ".xlsx", FileFormat:=51
    End With
End Sub
[/vba]

Автор - RAN
Дата добавления - 08.02.2021 в 22:27
ILYA_SERGEEVICH_1987 Дата: Четверг, 18.02.2021, 19:13 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Огромное спасибо все работает, если не затруднит скиньте код в личном сообщении с комментариями, так как аналогичных задач достаточно много, возможно придётся немного видоизменять.
 
Ответить
СообщениеОгромное спасибо все работает, если не затруднит скиньте код в личном сообщении с комментариями, так как аналогичных задач достаточно много, возможно придётся немного видоизменять.

Автор - ILYA_SERGEEVICH_1987
Дата добавления - 18.02.2021 в 19:13
RAN Дата: Четверг, 18.02.2021, 19:18 | Сообщение № 7
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Затруднит.


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеЗатруднит.

Автор - RAN
Дата добавления - 18.02.2021 в 19:18
ILYA_SERGEEVICH_1987 Дата: Суббота, 20.02.2021, 22:14 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Хорошо, все равно спасибо !!!!!
 
Ответить
СообщениеХорошо, все равно спасибо !!!!!

Автор - ILYA_SERGEEVICH_1987
Дата добавления - 20.02.2021 в 22:14
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Свод данных при помощи макроса (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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