將列編譯爲單個工作表

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只要在數據表中有一個D值，就可以在新表格的A和B列。

一旦用完了數值，它就會前進到下一張紙上，並將新副本追加到「課程代碼」編譯表的列表底部。

宏運行，創建新工作表，並正確標題列。但是，它不會將任何所需的信息複製到此新表中。我在這裏犯了什麼錯誤？

預先感謝您的幫助，並告訴我是否有任何信息我缺少以獲得準確答案。

Answer 1

這將從柱A & d附加數據上的所有表格至一個新的 「課程代碼」 片材，柱A &乙

---

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 

---