Question

我需要将成对的课程代码和相应的类别从几个工作表上的两个非相邻列复制到编译所有对的单个工作表上。

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

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

这样的东西

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

我也不能对任何给定的工作表使用硬编码范围，因为它们都是不同的并且经常在变化。但是，数据一致地在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

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

一旦用完了值，它就会进入下一张表格，将新副本附加到＆＃34;课程代码＆＃34;的列表底部。汇编表。

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

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

Answer 1

这将附加Col A＆amp; A的数据。 D在所有表格上，到新的“课程代码”表，Col A＆amp;乙

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

Compiling Columns

将列编译为单个工作表

1 个答案: