Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Автоматическое копирование данных с одного листа на другой, Ввод данных с автоматическим переносом на новый лист и в новый столбец
 
#1
07.11.2022 09:42:39
Добрый день. Нужна Ваша помощь. Форум полистал, но ничего похожего ненашел, может плохо искал.
Дано:
В книге имееется 4 листа.
1 лист для ввода данных. в нем вводятся месяц, год и данные в столбцы №1:№2; №3.
2 лист это обобщающий лист по введеным данным со столбца №1.
3 лист это обобщающий лист по введеным данным со столбца №2
4 лист это обобщающий лист по введеным данным со столбца №3
Задача:
При вводе новых данных на странице ввода, чтобы на остальных листах создавался столбец с названием месяца и года, который указан на странице ввода и записывались все данные во вновь созданный столбец. далее после очистки формы и изменения месяца опять создавался новый столбец на остальных листах.

Сейчас я это выполняю следующим образом:
1.) Заполняю 1 лист.
2.) на следующем листе вручную пишу месяц и год в новом столбце
3.) копирую столбец и переношу в на нужный лист.

Если не затруднит, уже устал так делать.
Если непонятно описал, напишите посторяюсь уточнить.
Заранее спасибо.
 
 
 
#2
07.11.2022 11:36:56
Код
Sub myCopy()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("Ввод")
    
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    With sh1
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                arr = .Cells(2, xx).Resize(10)
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                CopyRange arr, sh2, colName
            
                Set sh2 = Nothing
            End If
        Next
    End With
End Sub

Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub
 
 
 
#3
07.11.2022 11:50:26
Отлично. Работает. Огромное Спасибо.
Этот вопрос можно решить только через макрос? (я в них чайник)
Я создал кнопку и Ваш код вставил в нее, а можно чтобы после нажатия на эту кнопку данные не только перенеслись а еще и очистилась форма ввода данных для ввода новых данных?
 
 
 
#4
07.11.2022 12:40:43
Цитата
написал:
не только перенеслись а еще и очистилась форма
Код
Sub myCopy()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("Ввод")
     
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    With sh1
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                With .Cells(2, xx).Resize(10)
                    arr = .Value
                    .ClearContents
                End With
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                CopyRange arr, sh2, colName
             
                Set sh2 = Nothing
            End If
        Next
    End With
End Sub
 
Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub
 
 
 
#5
07.11.2022 13:39:01
.
Изменено: werdan - 15.04.2023 07:04:42
 
 
 
#6
26.11.2022 08:58:25
Добрый день. Все работает. ОГРОМНОЕ СПАСИБО!!! Но столкнулся с такой проблеммой, после ввода данных если случайно нажать на кнопку с макросом 2 раза то все данные только что введеные стираются и на стронице ввода и на листах.  Как можно избежать этого?  
Изменено: werdan - 15.04.2023 07:05:45
 
 
 
#7
26.11.2022 09:02:07
не нажимайте случайно на кнопку с макросом 2 раза )) а так попробуйте этот код

Код
Sub myCopy()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    
    If MsgBox("Скопировать данные?", vbYesNo + vbQuestion, "Копирование") = vbNo Then Exit Sub
    
    Set sh1 = Sheets("Ввод")
    
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    With sh1
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                With .Cells(2, xx).Resize(10)
                    arr = .Value
                    .ClearContents
                End With
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                CopyRange arr, sh2, colName
              
                Set sh2 = Nothing
            End If
        Next
    End With
End Sub
  
Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub
Изменено: New - 26.11.2022 09:03:12
 
 
 
#8
26.11.2022 10:08:58
Мне понравилось такое решение, значительно уменьшает вероятность двойного нажатия. Только если опять 2 раза нажать ДА все сотрется. А можно при очишении формы, очистить и месяц и если месяц не введен то не копировать и не очищать форму, а выдавать ошибку введите месяц.
 
 
 
#9
26.11.2022 10:45:19
Код
Sub myCopy()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim LastRow As Long
    
    If MsgBox("Скопировать данные?", vbYesNo + vbQuestion, "Копирование") = vbNo Then Exit Sub
     
    Set sh1 = Sheets("Ввод")
     
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    
    With sh1
        If .FilterMode = True Then .ShowAllData
        If .Cells(1, 6).Value = Empty Or .Cells(1, 7).Value = Empty Then
            MsgBox "Введите название месяца в ячейку F1 и год в ячейку G1", vbExclamation, "Внимание"
            Exit Sub
        End If
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                With .Cells(2, xx).Resize(LastRow)
                    arr = .Value
                    .ClearContents
                End With
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                .Cells(1, 6).Value = Empty
                CopyRange arr, sh2, colName
                Set sh2 = Nothing
            End If
        Next
    End With
    MsgBox "Данные скопированы!", vbInformation, "Копирование"
End Sub
   
Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub
 
 
 
#10
26.11.2022 11:49:32
Отлично!!! Огромное спасибо!!!
 
 
 
#11
19.03.2023 11:34:22
Добрый день.

У меня ни как не получается доработать этот макрос (я в них совсем ничего не понимаю), если не затруднит нужна помощь.

1.) При переносе данных, чтобы данные по месяцам записывались, не в каждый столбик,  через 1 столбик (чтобы в этом столбике вести расчет).
2.) При переносе данных в ячейке нет, то записывать данные из предыдущего месяца.
3.) Если это возможно при нажатии кнопки на листе данные изменять месяц на следующий.
Код
Sub Кнопка1_Щелчок()
   Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("Ввод")
       
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    With sh1
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                With .Cells(2, xx).Resize(10)
                    arr = .Value
                    .ClearContents
                End With
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                CheckEmpty arr
                CopyRange arr, sh2, colName
               
                Set sh2 = Nothing
            End If
        Next
         
        Dim dt As Date
        On Error Resume Next
        dt = DateValue("01 " & colName)
        On Error GoTo 0
        If dt > 0 Then
            dt = DateSerial(Year(dt), Month(dt) + 1, 1)
            .Cells(1, 6).Value = Format(dt, "MMMM")
            .Cells(1, 7).Value = Year(dt)
        End If
         
    End With
End Sub
   
Private Sub CheckEmpty(arr As Variant)
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then Exit Sub
    Next
    For yy = 1 To UBound(arr, 1)
        arr(yy, 1) = "=RC[-2]"
    Next
End Sub
 
   
Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
    
End Sub
Изменено: werdan - 15.04.2023 07:11:28
 
 
 
#12
19.03.2023 11:35:08
.
Изменено: werdan - 15.04.2023 07:17:37
 
 
 
#13
20.03.2023 07:19:07
.
Изменено: werdan - 15.04.2023 07:12:04
 
 
 
#14
20.03.2023 09:17:20
werdan, скажите, а Вы когда на работу устраивались, наверное тест на знание Excel проходили😁
 
 
 
#15
20.03.2023 11:16:45
Если не затруднит где можно почитать про макросы?  
Изменено: werdan - 15.04.2023 07:12:35
 
 
 
#16
20.03.2023 11:21:28
Цитата
werdan: начальство за это решения меня почестями и похвалами не одарило
получается, мы не вам помогаем, а начальству — вас неблагодарно использовать. Нет никакого желания…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#17
20.03.2023 12:43:32
Цитата
написал:
не в каждый столбик,  через 1 столбик
Код
xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2

Цитата
написал:
помогаем, а начальству — вас неблагодарно использовать
Не будем менять работающую схему )
 
 
 
#18
20.03.2023 12:53:42
Цитата
написал:
при нажатии кнопки на листе данные изменять месяц на следующий.
Код
Sub Кнопка1_Щелчок()
   
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("Ввод")
      
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    With sh1
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                With .Cells(2, xx).Resize(10)
                    arr = .Value
                    .ClearContents
                End With
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                CheckEmpty arr
                CopyRange arr, sh2, colName
              
                Set sh2 = Nothing
            End If
        Next
        
        Dim dt As Date
        On Error Resume Next
        dt = DateValue("01 " & colName)
        On Error GoTo 0
        If dt > 0 Then
            dt = DateSerial(Year(dt), Month(dt) + 1, 1)
            .Cells(1, 6).Value = Format(dt, "MMMM")
            .Cells(1, 7).Value = Year(dt)
        End If
        
    End With
End Sub
  
Private Sub CheckEmpty(arr As Variant)
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then Exit Sub
    Next
    For yy = 1 To UBound(arr, 1)
        arr(yy, 1) = "=RC[-2]"
    Next
End Sub

  
Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub


Цитата
где можно почитать про макросы?
Профессиональное программирование на VBA. Дж. Уокенбах
Изменено: МатросНаЗебре - 20.03.2023 12:55:59
 
 
 
#19
20.03.2023 13:28:03
Цитата
Цитата
Цитата
Изменено: werdan - 15.04.2023 07:13:58
 
 
 
#20
20.03.2023 13:30:23
Цитата
Цитата
Изменено: werdan - 15.04.2023 07:19:38
 
 
 
#21
20.03.2023 13:33:25
Цитата
Цитата
2 вопрос, что то можно сделать?

Понятно, спасибо!!!
и за книжку, спасибо!!!
Буду разбираться, может когда нибудь и я пригожусь на этом форуме :-)
Изменено: werdan - 15.04.2023 07:24:13
 
 
 
#22
01.04.2023 09:38:49
,
Изменено: werdan - 15.04.2023 06:59:38
 
 
 
#23
01.04.2023 09:40:36
При переносе данных если ячейка пуста то вставить данные из предыдущего месяца.
 
 
 
#24
01.04.2023 13:15:47
werdan, Здравствуйте. А правила форума почитать про оформление кода, видать тоже никак?
 
 
 
#25
01.04.2023 17:12:56
.
Изменено: werdan - 15.04.2023 07:21:00
 
 
 
#26
01.04.2023 17:15:13
Цитата
Изменено: werdan - 15.04.2023 07:21:16
 
 
 
#27
07.04.2023 08:37:03
Добрый день. Как удалить созданую мной тему, полностью?
Изменено: werdan - 15.04.2023 07:21:34
 
 
 
#28
07.04.2023 08:42:00
ваша личная тема уже не совсем и личная,
все что тут написано - становится общим достоянием понимающего русский язык человечесва))
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#29
07.04.2023 09:12:21
Цитата
werdan написал:
А начальство - молодая девушка хоть и своенравная и вредная, куда она без нас вот и просит помочь хоть и не всегда благодарна.
наверное она просто неудовлетворённая, может не там ищите решение проблемы 😉
 
 
 
#30
13.04.2023 07:32:40
.
Изменено: werdan - 15.04.2023 07:22:01
 
 
 
Страницы: 1 2 След.
Наверх