excel - 合并两列，然后将不同的数据复制到新工作表

Question

我想合并两列，然后将不同的数据复制到新工作表中。

有人帮我用这个 VBA 代码来合并数据。

如何插入新工作表并向其传输数据(根据分数)？

Sub MergeCols()
    Dim m As Long
    Application.ScreenUpdating = False
    m = Range("A" & Rows.Count).End(xlUp).Row
    Range("A" & m + 1).Resize(m - 1, 2).Value = Range("B2").Resize(m - 1, 2).Value
    Range("B1").Resize(m).Delete Shift:=xlShiftToLeft
    Application.ScreenUpdating = True
End Sub

Answer 1

根据条件转换数据并导出到多个工作表

描述

• 此代码根据给定的除数将转换后的数据从一个工作表导出到同一工作簿中的多个新工作表。假定源工作表中的数据具有标题行，最后一列中的唯一值用于确定哪些数据行应分组在一起并导出到新工作表，其名称基于除以该工作表的结果除数的唯一值。每个新工作表将包含两列:“名称”和“分数”，其中“名称”对应于源工作表中最后一列之前的列，“分数”对应于最后一列。

代码

Sub ExportTransformedData()

    ' Define constants.
    
    Const SRC_SHEET As String = "Sheet1"
    Const SRC_UNIQUE_COLUMN As Long = 3
    
    Const DST_SHEET As String = "Sheet2"
    Dim dHeaders(): dHeaders = VBA.Array("Name", "Score")
    
    Const DIVISOR As Long = 10
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the source data to the source array.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count - 1 ' no headers
    
    Dim sData(): sData = srg.Resize(srCount).Offset(1).Value
       
    ' Write the unique values and row numbers to a dictionary.
       
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
       
    Dim sr As Long, sStr As String
    
    For sr = 1 To srCount
        sStr = CStr(Int(sData(sr, SRC_UNIQUE_COLUMN) / DIVISOR))
        If Not dict.Exists(sStr) Then Set dict(sStr) = New Collection
        dict(sStr).Add sr
    Next sr
    
    ' Use the information from source array and the dictionary to return
    ' the result in the destination array to be copied to each worksheet.
    
    Dim dcCount As Long: dcCount = SRC_UNIQUE_COLUMN - 1
    
    Application.ScreenUpdating = False
    
    Dim dsh As Object, dData(), Key, rItem, dr As Long, dc As Long
    
    For Each Key In dict.Keys
        ReDim dData(1 To 1 + dict(Key).Count * dcCount, 1 To dcCount)
        ' Write headers.
        For dc = 1 To dcCount
            dData(1, dc) = dHeaders(dc - 1)
        Next dc
        ' Write data.
        dr = 1
        For Each rItem In dict(Key)
            For dc = 1 To dcCount
                dr = dr + 1
                dData(dr, 1) = sData(rItem, dc)
                dData(dr, 2) = sData(rItem, SRC_UNIQUE_COLUMN)
            Next dc
        Next rItem
        ' Delete existing sheet.
        On Error Resume Next
            Set dsh = wb.Sheets(Key)
        On Error GoTo 0
        If Not dsh Is Nothing Then
            Application.DisplayAlerts = False ' delete without confirmation
                dsh.Delete
            Application.DisplayAlerts = True
            Set dsh = Nothing ' reset for the next iteration
        End If
        ' Add new sheet.
        With wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            .Name = Key ' rename
            With .Range("A1").Resize(, dcCount)
                .Resize(dr).Value = dData ' write
                ' Format.
                .Font.Bold = True
                .EntireColumn.AutoFit
            End With
        End With
    Next Key
    
    ' Inform.
    
    Application.ScreenUpdating = True
    
    MsgBox "Transformed data exported.", vbInformation

End Sub

流程

• 代码首先定义源工作表名称的常量、要分组的唯一值的列索引、目标工作表名称以及用于新工作表中两列的标题。

• 接下来，代码设置工作簿、源工作表和源数据范围的变量。源数据区域定义为源工作表中单元格 A1 的当前区域，其中包括与单元格 A1 相邻并包含单元格 A1 的所有单元格。还会计算源数据范围(不包括标题行)中的行数。

• 然后将源数据存储在二维数组中，并创建一个字典对象来存储最后一列中的唯一值以及与每个值关联的行号。

• 然后，代码会迭代源数据数组，并根据最后一列中的值除以除数，将每个行号添加到字典中的相应集合中。

• 填充字典后，代码会为源数据中的列数设置变量，并关闭屏幕更新以加快代码速度。

• 然后，代码会迭代字典中的每个唯一键，并为要导出到新工作表的数据创建一个新的二维数组。该数组的大小可容纳与键关联的行数乘以源数据中的列数，加上标题行的一行。

• 然后将 header 写入数组的第一行，并将与键集合中每个行号关联的数据写入数组。每行的数据都会从源数据数组复制到新数组中的适当位置，并将新数组写入新工作表，其名称与键值相对应。如果具有该名称的工作表已存在，则会在创建新工作表之前将其删除，无需确认。

• 最后，重新打开屏幕更新，并显示消息框，指示转换后的数据已导出。