Я пытаюсь создать макрос VBA, который дублирует лист, а затем копирует данные на листе в новый столбец

Question

Это моя первая публикация о переполнении стека, поэтому любые отзывы приветствуются.

Сейчас я пытаюсь запрограммировать макрос, который выполняет следующие действия:

1. Дублирует текущий лист и перемещает новый лист в начало книги (новый лист также именуется пользователем через экран ввода)
2. Копирует данные из столбца D в столбец E на основе 3 критериев в столбцах A- C

Я кодировал Шаг 1, но на Шаге 2 у меня проблемы. Мне нужно скопировать данные из одного места на листе в другое на основе критериев. Ниже приведен пример того, что я пытаюсь сделать

Пример для макроса шага 2:

По сути, я хочу чтобы скопировать «Продажи за день» в «Продажи за предыдущий день» на новом листе в соответствии с каждым из 3 критериев (Имя, Страна, Продукт) в случае изменения чего-либо и убедиться, что значения копируются правильно.

Пожалуйста, дайте мне знать, если необходимо предоставить какую-либо другую информацию!

К вашему сведению, вот код, который у меня уже есть для шага 1:

Public Sub CopySheetAndRename()

Dim newName As String

    On Error Resume Next
    newName = InputBox("Enter the date for the new worksheet")

    If newName <> "" Then
        ActiveSheet.Copy Before:=Sheets(1)
        On Error Resume Next
        ActiveSheet.Name = newName
    End If
End Sub

Answer 1

Пожалуйста, проверьте также следующий код. Работает быстро (в памяти, используя массивы) для большого диапазона:

Sub testMoveData()
  Dim shA As Worksheet, newSh As Worksheet, arrA As Variant, ArrFin As Variant
  Dim i As Long, newName As String
    Set shA = ActiveSheet
    arrA = shA.Range("A1:E" & shA.Range("A" & Cells.Rows.count).End(xlUp).row).Value
    ReDim ArrFin(1 To UBound(arrA, 1), 1 To 5)
    For i = 1 To UBound(arrA, 1)
        If i = 1 Then
            ArrFin(i, 1) = arrA(i, 1): ArrFin(i, 2) = arrA(i, 2): ArrFin(i, 3) = arrA(i, 3)
            ArrFin(i, 4) = arrA(i, 4): ArrFin(i, 5) = arrA(i, 5)
        Else
            ArrFin(i, 1) = arrA(i, 1): ArrFin(i, 2) = arrA(i, 2): ArrFin(i, 3) = arrA(i, 3)
            ArrFin(i, 5) = arrA(i, 4)
        End If
    Next i

    newName = InputBox("Enter the date for the new worksheet", "New sheet name setting")
    If newName = "" Then MsgBox "No sheet name allocated": Exit Sub
    Set newSh = ActiveWorkbook.Sheets.Add(Before:=ActiveWorkbook.Worksheets(1)
      newSh.Name = newName
      With newSh.Range("A1").Resize(UBound(ArrFin, 1), UBound(ArrFin, 2))
        .Value = ArrFin
        'A little formatting on the new sheet:
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
        .BorderAround Weight:=xlThick
      End With
      With newSh.Range(newSh.Cells(1, 1), newSh.Cells(1, UBound(ArrFin, 2)))
        .Font.Bold = True
        .EntireColumn.AutoFit
      End With
End Sub

Answer 2

Sub MoveOver()

'create variables
Dim lastRow As Long

'find lastRow
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

'change i to whatever your starting row is. Cells(i, #), the # indicates the column index
For i = 2 To lastRow
Cells(i, 5).Value = Cells(i, 4)
Cells(i, 4).Value = 0
Next i 'new loop starts

End Sub

При более внимательном рассмотрении кажется, что вы просто хотите перенести сегодняшние данные о продажах на предыдущий день, а затем очистить "сегодня". Код выше должен помочь вам.

Редактировать: Изменены ячейки (). Очистить до .Value и установить 0, чтобы сохранить форматирование.