代码之家 › 专栏 › 技术社区 › user8517443

Excel理论:将数据从多个选项卡合并到一个选项卡

vba excel-formula excel

-2

user8517443 · 技术社区 · 7 年前

我有4张数据表,每张数据表中有数千行。每一页中都有一列,我想将其合并为第五页。在本专栏中,我想确保前四页中的每个名字都包含在一个完整的列表中,没有重复。

请参见下面的一个简单示例,但请设想每张图纸上有20000行具有复杂名称。有谁能想出一种方法来做到这一点,而不需要每次输入发生变化时都进行调整?我一直在尝试使用数据透视图向导,但没有成功。

Sheet 1     Sheet 2     Sheet 3     Sheet 4      Ideal Sheet 5
Dog          Cat         Fish       Giraffe       Dog
Hamster      Dog         Lhama      Cat           Cat
Giraffe      Elephant    Dog        Fish          Fish
                                                 Giraffe
                                                 Elephant
                                                 Hamster
                                                  Lhama

这是我想出的代码,以防有人感兴趣时解决这个问题。“Zone&Fam”只指定我感兴趣的列。

Sub GetUniqueZoneFam()
    Application.ScreenUpdating = False

    Dim Lastrow As Long

    Worksheets("Calculation Indv").Range("A:A").ClearContents

    Worksheets("fcst fg").Activate
    Range("Fcst_Fg[Zone & Fam]").Copy
    Worksheets("Calculation Indv").Activate
    Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    Worksheets("fcst ps").Activate
    Range("Fcst_PS[Zone & Fam]").Copy
    Worksheets("Calculation Indv").Activate
    Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    Worksheets("sales fg").Activate
    Range("Sales_FG[Zone & Fam]").Copy
    Worksheets("Calculation Indv").Activate
    Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    Worksheets("sales ps").Activate
    Range("Sales_PS[Zone & Fam]").Copy
    Worksheets("Calculation Indv").Activate
    Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    Application.CutCopyMode = False

    Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("A1").Select

    Worksheets("Calculation Indv").Range("A1").Value = "Zone & Fam"
    Worksheets("Calculation Indv").Range("A1").Font.Bold = True


    Application.ScreenUpdating = True
    MsgBox ("Done!")

End Sub

2 回复 | 直到 6 年前

JNevill 7 年前

在vba中,这看起来类似于以下内容(完全未经测试,在VBE之外编写,可能有很多错误,肯定需要调整以适合数据所在的工作表名称和列):

Dim wsName as String
Dim lastRow as Long
Dim writeRow as Long

'set the row on which we are going to start writing data to "Sheet 5"
writeRow = 1

'Loop though your sheets to copy from
For Each wsName In Array("Sheet 1", "Sheet 2", "Sheet 3", "Sheet 4")

    'determine the last used row in the worksheet we are copying from
    lastRow = Sheets(wsName).Range("A1").End(xlDown).Row

    'grab the data
    Sheets(wsName).Range("A1:A" & lastRow).Copy Destination:=Sheets("Sheet 5").Range("A" & writeRow)

    'increment the writeRow
    writeRow = writeRow + lastRow

Next wsName

'Now that all the data is copied, dedup it
Sheets("Sheet 5").Range("A1:A" & writeRow).RemoveDuplicates Columns:=Array(1), Header:=xlNo

user8517443 user8517443 6 年前

子GetUniqueZoneFam() 应用屏幕更新=错误

Dim Lastrow As Long

Worksheets("Calculation Indv").Range("A:A").ClearContents

Worksheets("fcst fg").Activate
Range("Fcst_Fg[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("fcst ps").Activate
Range("Fcst_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("sales fg").Activate
Range("Sales_FG[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("sales ps").Activate
Range("Sales_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Application.CutCopyMode = False

Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select

Worksheets("Calculation Indv").Range("A1").Value = "Zone & Fam"
Worksheets("Calculation Indv").Range("A1").Font.Bold = True


Application.ScreenUpdating = True
MsgBox ("Done!")

End Sub