Question

我对VBA很新。基本上我在表1上有下表

根据我们收到的国家/联系原因，我们每天都会收到＃电子邮件。

在一天结束时，我想指定一个宏按钮，将按当前日期将数据复制并粘贴到工作表2。

Answer 1

我为此写了一个动态解决方案：

Option Explicit
Option Base 1

Type EmailData
    us As Object
    ca As Object
End Type

Public Sub RunDataMove()
Dim wsDataFrom As Worksheet
Dim wsDataTo As Worksheet
Dim eData As EmailData
Dim i As Long

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    Set wsDataFrom = ThisWorkbook.Worksheets("DataFrom") 'Change Worksheet names
    Set wsDataTo = ThisWorkbook.Worksheets("DataTo") 'Change Worksheet names

    Set eData.us = CreateObject("Scripting.Dictionary")
    Set eData.ca = CreateObject("Scripting.Dictionary")

    With wsDataFrom
        For i = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
            eData.us.Add .Cells(i, 3).Value, .Cells(i, 1).Value
            eData.ca.Add .Cells(i, 3).Value, .Cells(i, 2).Value
        Next i
    End With

    Call MoveDataByDate(wsDataTo, eData, DateAdd("d", 0, Date)) 'Change add days +/- if needed

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

    MsgBox "Data for " & Date & " has been moved or updated"

End Sub

Public Sub MoveDataByDate(ByRef wsTo As Worksheet, ByRef eData As EmailData, ByVal eDate As Date)
Dim obj As Variant, i As Long, usCol As Long, caCol As Long, dCol As Long, keyName As String
    With wsTo
        For i = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
            If .Cells(1, i).Value = eDate Then
                dCol = i
                usCol = i
                caCol = i + 1
                Exit For
            End If
        Next i
        If dCol = 0 And i <> 1 Then
            usCol = i
            caCol = i + 1
        Else
            usCol = 2
            caCol = 3
        End If
        If .Cells(3, 1).Value = "" Then
            i = 3
            For Each obj In eData.us
                .Cells(i, 1).Value = obj
                i = i + 1
            Next obj
            .Cells.EntireColumn.AutoFit
        End If
        For i = 3 To .Cells.SpecialCells(xlCellTypeLastCell).Row
            keyName = .Cells(i, 1).Value
            If eData.us.exists(keyName) Then
                .Cells(i, usCol).Value = eData.us(keyName)
            End If
            If eData.ca.exists(keyName) Then
                .Cells(i, caCol).Value = eData.ca(keyName)
            End If
        Next i
        .Cells(1, usCol).Value = eDate
        .Range(.Cells(1, usCol), .Cells(1, caCol)).Merge
        .Cells(2, usCol).Value = "US"
        .Cells(2, caCol).Value = "CA"
        With .Range(.Cells(1, usCol), .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row, caCol))
            .ColumnWidth = 8
            .HorizontalAlignment = xlCenter
        End With
    End With
End Sub

按当前日期将工作表1中的一系列数据复制并粘贴到另一个工作表2

1 个答案: