将列编译为单个工作表
我需要将成对的课程代码和各个类别从几个工作表上的两个不相邻的列复制到一个工作表中编译所有对。
一门课程可能分为三或四个类别，并存在三，四个工作表上，我需要对每一门课程进行独特的观察。
我还有其他的工作表，所以我不能简单地使用类似的东西
Select Case sh.Name Case Is <> "All Course Codes" 对于任何给定的工作表，我也不能使用硬编码的范围，因为它们都是不同的，而且经常在变化。 尽pipe如此，数据一直在A列和D列。 我对VBA知之甚less，所以我从各种渠道拼凑出来：
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
为了解释，我试图通过名称来select每个工作表，然后在D列中运行，并将数据从A和D复制到新工作表上的列A和B，只要数据表中有一个值D即可。
一旦用完了值，它就会进入下一张表格，将新的副本附加到“课程代码”编制表中列表的底部。
macros运行，创build新工作表，并正确地标题列。 但是，它不会将任何所需的信息复制到此新表中。 我在这里犯了什么错误？
预先感谢您的帮助，并告诉我是否有任何信息我缺less，以获得准确的答案。
这会将所有表格上的A＆D的数据附加到新的“课程代码”表格A和B上
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
