Question

我的列A包含所有现有类别，新类别列在C列中。我正在尝试确定如何获取这些新类别，并将它们添加到列“a”（如果它们尚未列在列中） A.在示例中，列C中的新类别被添加到列A，即使列A中已经存在。我还需要if-then行中的范围（“a1”）作为动态范围，因为新类别将在代码运行时添加。一些建设性的批评将非常感谢，以帮助我将来。

Sub newcategory()


Dim newcatcount As Integer
Dim i As Integer


newcat = Range("c100000").End(xlUp).Row


For i = 1 To newcat


    If Cells(i, 3).Value <> Range("a1") Then
    Cells(i, 3).Select
    Selection.copy
    Range("a100000").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste

    End If

Next




End Sub

Answer 1

请试一试......

Sub AddNewCategories()
Dim lrA As Long, lrC As Long, i As Long, j As Long
Dim x, y, z(), dict

lrA = Cells(Rows.Count, 1).End(xlUp).Row
lrC = Cells(Rows.Count, 3).End(xlUp).Row

'Array to hold the categories in column A starting from Row1, assuming the categories start from A1. If not, change it accordingly.
x = Range("A1:A" & lrA).Value

'Array to hold the new categories in column C starting from Row1, assuming the categories start from C1. If not, change it accordingly.
y = Range("C1:C" & lrC).Value

Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For i = 1 To UBound(y, 1)
    If Not dict.exists(y(i, 1)) Then
        dict.Item(y(i, 1)) = ""
        j = j + 1
        ReDim Preserve z(1 To j)
        z(j) = y(i, 1)
    End If
Next i

If j > 0 Then
    Range("A" & lrA + 1).Resize(j).Value = Application.Transpose(z)
End If
Set dict = Nothing
End Sub

Answer 2

你可以使用内置RemoveDuplicates()函数的excel，如下所示（注意注释）：

Option Explicit

Sub newcategory()
    Dim newcat As Range

    With Worksheets("Categories") ' change "Categories" to your actual sheeet name
        Set newcat = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp)) ' get the range of all nwe categories in reference sheet column C from row 1 down to last not empty one
        .Cells(.Rows.Count, 1).End(xlUp).Resize(newcat.Rows.Count).Value = newcat.Value ' append new categories values below existing categories in column A
        .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo ' remove duplicates
    End With
End Sub

从当前范围内未找到的列表粘贴到当前范围的底部

2 个答案: