Vba 将列编译为单个工作表

我需要将多个工作表上两个非相邻列的成对课程代码和各自的类别复制到一个工作表上，以编译所有成对的课程代码和类别

一门课程可能分为三到四个类别，并存在于三到四张工作表上，我需要对其中每一项进行独特的观察

我还有其他的工作表，所以我不能简单地使用

Select Case sh.Name
Case Is <> "All Course Codes"

选择Case sh.Name
案例为“所有课程代码”

我也不能对任何给定的工作表使用硬编码范围，因为它们都是不同的，并且经常变化。不过，数据始终在A列和D列中。我对VBA知之甚少，因此我从各种来源拼凑了这一点：

Dim sh As Worksheet
Dim DestSh As Worksheet
Dim LastRow As Long

ActiveWorkbook.Worksheets("Course Codes").Delete

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Course Codes"
DestSh.Cells(1, 1).Value = "Category"
DestSh.Cells(1, 2).Value = "Course Code"

For Each sh In ActiveWorkbook.Worksheets
    Select Case sh.Name
    Case "Category1", "Category2", "Category3", "Category4", "Category5", "Category6"

        FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
        ThisValue = Cells(x, 4).Value
        NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1

        For x = 2 To FinalRow
            If ThisValue <> "" Then
            Cells(x, 1).Copy
            Destination DestSh.Cells(NextRow, 1).Select
            End If
        Next
    End Select
Next
End Sub

Dim sh As工作表
将DestSh设置为工作表
最后一排一样长
活动工作簿。工作表（“课程代码”）。删除
设置DestSh=ActiveWorkbook.Worksheets.Add
DestSh.Name=“课程代码”
DestSh.Cells（1,1）.Value=“类别”
DestSh.Cells（1，2）.Value=“课程代码”
对于ActiveWorkbook.工作表中的每个sh
选择案例名称
案件“第1类”、“第2类”、“第3类”、“第4类”、“第5类”、“第6类”
FinalRow=单元格（Rows.Count，1）.End（xlUp）.Row
此值=单元格（x，4）。值
NextRow=单元格（Rows.Count，1）。结束（xlUp）。行+1
对于x=2到最终路径
如果该值为“”，则
单元格（x，1）。复制
目标DestSh.Cells（下一步，1）。选择
如果结束
下一个
结束选择
下一个
端接头

为了解释，我尝试按名称选择每个工作表，然后运行D列，并将数据从A和D复制到新工作表上的A和B列，只要数据表上的D中有一个值

一旦值用完，它将进入下一页，将新的副本追加到“课程代码”汇编页列表的底部

宏将运行、创建新工作表并正确命名列。但是，它不会将任何所需信息复制到此新工作表中。我在这里犯了什么错误

---

提前感谢您的帮助，如果我缺少任何信息，请告诉我，以获得准确答案。

这将在所有表格中，将A&D列的数据附加到新的“课程代码”表格中，A&B列

---

---

---

您的代码有几个问题：1。您使用的x没有初始值（ThisValue=单元格（x，4）.value）2。NextRow应该是“FinalRow+1”，而不是再次查找最后一行3。这不是粘贴数据：只需复制，然后选择目标范围。谢谢，这是一个很好的开始。然而，我遇到了一个bug，我的基本VBA技能还不足以让我知道它是从哪里来的。当我运行脚本时，它会正确地创建带有格式化标题的新工作表。但是，它只从case参数中提取第一张表，而不是处理所有指定的表，并将原始表上的Col A中的数据插入课程代码表上的Col A和Col B中。我想这可能与范围有关，但你给我的语法有点超出了我的技能水平。有什么见解吗？再次感谢。我正在从所有工作表的子集中提取。非常感谢您的帮助，我从这个问题中学到的有关VBA的知识比我所有基本的宏编写都要多。我认为问题的出现是因为我试图从这些工作表中提取数据。你觉得怎么样？我改进了我的测试文件并修复了你提到的问题（表不影响数据提取-我只是将我的3张测试表转换成表，它的工作原理是一样的）。我还添加了更多的注释来描述stepsI在这里和那里做了一些调整-得到了一堆额外的行和一些错误值（不知道从哪里来，在任何表中都找不到），但这些很容易删除。这看起来很棒！谢谢你，保罗！

Option Explicit

Sub getData()

    Const OFFSET        As Byte = 2
    Const COL1_NAME     As String = "Category"
    Const COL2_NAME     As String = "Course Codes"
    Const SHEET_NAMES   As String = "Category1,Category2,Category3,Category4,Category5,Category6"

    Dim thisWS  As Worksheet
    Dim destWS  As Worksheet
    Dim last1   As Long
    Dim last2   As Long
    Dim rng     As Range

    Application.DisplayAlerts = False   'turn off sheet deletion warning
    Application.ScreenUpdating = False  'turn off display

    For Each thisWS In ActiveWorkbook.Worksheets    'look for sheet "Course Codes"
        If thisWS.Name = COL2_NAME Then
            thisWS.Delete                           'if found, delete it
            Exit For
        End If
    Next
    Set destWS = Worksheets.Add(Sheets(1))          'create a new sheet "Course Codes"
    With destWS
        .Name = COL2_NAME
        .Cells(1, 1).Value = COL1_NAME              'add header "Category"
        .Cells(1, 2).Value = COL2_NAME              'add header "Course Codes"
        With .UsedRange.Rows(1)
            .HorizontalAlignment = xlCenter         'header alignment: center
            .Font.Bold = True                       'header font: bold
            .Interior.Color = RGB(222, 222, 222)    'header cell background: grey
        End With
    End With

    last2 = OFFSET                                  'first row on "Course Codes"

    For Each thisWS In ActiveWorkbook.Worksheets    'check all sheets if in SHEET_NAMES

        If InStr(1, SHEET_NAMES, thisWS.Name, vbBinaryCompare) > 0 Then

            last1 = thisWS.UsedRange.Rows.Count     'last row of current sheet

            If last1 > OFFSET Then                  'if the sheet has more than 2 rows

               'Col A - Destination sheet: destWS.Cells(Row, Col)
                Set rng = destWS.Range( _
                                        destWS.Cells(last2, 1), _
                                        destWS.Cells(last1 + last2 - OFFSET, 1))

                rng.Value = thisWS.Range("A2:" & "A" & last1).Value  'copy Col A to A

               'Col B - Destination sheet: destWS.Cells(Row, Col)
                Set rng = destWS.Range( _
                                        destWS.Cells(last2, 2), _
                                        destWS.Cells(last1 + last2 - OFFSET, 2))

                rng.Value = thisWS.Range("D2:" & "D" & last1).Value  'copy Col D to B

                last2 = last2 + last1 - 1   'increment offset by (total copied rows - 1)
            End If
        End If
    Next
    destWS.UsedRange.Columns.AutoFit        'resize columns to fit the widest text
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub