vba 根据特定单元格值从excel复制特定行

Copy specific rows from excel based on a specific cell value

提问by Warlord

I have multiple worksheets in a excel book and each of these worksheet contains module wise data. I want to copy all the module data from each worksheet and paste it in a new excel book. How can this be done using VBScript?

我在一本 excel 书中有多个工作表，每个工作表都包含模块数据。我想从每个工作表中复制所有模块数据并将其粘贴到一个新的 excel 书中。如何使用VBScript做到这一点？

All sheets looks something like this in rawData.xls

所有工作表在rawData.xls 中看起来像这样

 A        B        C 
Module1  999     asda
Module2  22      asda
Module1  33      asda
Module7  44      asda
Module3  55      asda
Module2  66      asda
Module5  77      asda

I need to iterate all the sheets in rawData.xls, copy all rows containing "Module1" and paste it to result.xls, and repeat for Module2, Module3, ...

我需要迭代rawData.xls 中的所有工作表，复制所有包含“Module1”的行并将其粘贴到result.xls，然后对 Module2、Module3 重复...

Is there a way to make this kind of an automated one using VB Script?

有没有办法使用 VB Script 使这种自动化？

Any help is appreciated. Thanks in advance

任何帮助表示赞赏。提前致谢

My Code:

我的代码：

Sub copy() 
    Set objRawData = objExcel.Workbooks.Open("rawData.xls") 
    Set objPasteData = objExcel.Workbooks.Open("result.xls") 
    StartRow = 1 RowNum = 2 
    Do Until IsEmpty(objRawData.WorkSheets("Sheet1").Range("C" & RowNum)) 
      If objRawData.WorkSheets("Sheet1").Range("C" & RowNum) = "module1" Then
        StartRow = StartRow + 1 
        objPasteData.WorkSheets("Final").Rows(StartRow).Value = _ 
                objRawData.WorkSheets("Sheet1").Rows(RowNum).Value 
      End If 
      RowNum = RowNum + 1 
    Loop 
End Sub

回答by Ekkehard.Horner

Instead of letting the popular 'What have you tried?' coerce you into writing code without a plan, think about (and ask for) the know how/know to/methods/tools necessary for selecting specific rows of sheets/tables into new sheets/tables.

而不是让流行的“你尝试过什么？” 强迫您在没有计划的情况下编写代码，考虑（并要求）将特定行的工作表/表格选择为新工作表/表格所需的知识/知识/方法/工具。

"select" implies SQL and while Excel is not a database mangement system, you can use an .XLS as a database: with a little help from ADO.

“选择”意味着 SQL，虽然 Excel 不是数据库管理系统，但您可以使用 .XLS 作为数据库：在ADO 的帮助下。

So my plan would be:

所以我的计划是：

(1) Open an ADODB.Connectionto your source .XLS

(1) 打开一个ADODB.Connection到你的源 .XLS

(2) Get a list of all sheets/tables to process

(2) 获取要处理的所有工作表/表格的列表

(3) Use (2) to generate a statement like

(3) 使用 (2) 生成如下语句

SELECT [A] FROM [Tbl1] UNION SELECT [A] FROM [Tbl2] UNION SELECT [A] FROM [Tbl3] ORDER BY [A]

(4) Execute (3) and loop over the resultset

（4）执行（3）并循环遍历结果集

(5) For Each Module1 ... ModuleLast

(5) 对于每个 Module1 ... ModuleLast

(5a) To create the new sheet/table for Module M in your destination .XLS, execute a statement like

(5a) 要在目标 .XLS 中为模块 M 创建新工作表/表格，请执行如下语句

SELECT * INTO [TblModuleM]  IN "path\to\your\dst.xls" "Excel 8.0;" FROM [Tbl1] WHERE [A] = 'ModuleM'

(5b) For Each Tbl2 ... TblLast append the ModuleM rows using statements like

(5b) For Each Tbl2 ... TblLast 使用如下语句附加 ModuleM 行

INSERT INTO [TblModuleM]  IN "path\to\your\dst.xls" "Excel 8.0;" SELECT * FROM [TblT] WHERE [A] = 'ModuleM'

Demo code to give you some confidence in the plan and some keywords to look up:

演示代码让您对计划和一些关键字有信心：

  Const csSFSpec   = "..\data515369\src.xls"
  Const csDFSpec   = "..\data515369\dst.xls"
  Const csTables   = "[Tbl1] [Tbl2] [Tbl3]"

  Dim aTblNs  : aTblNs   = Split(csTables)
  Dim oFS     : Set oFS = CreateObject("Scripting.FileSystemObject")
  Dim sSFSpec : sSFSpec = oFS.GetAbsolutePathName(csSFSpec)
  Dim sDFSpec : sDFSpec = oFS.GetAbsolutePathName(csDFSpec)
  If oFS.FileExists(sDFSpec) Then oFS.DeleteFile sDFSpec

  Dim oDbS    : Set oDbS = CreateObJect("ADODB.Connection")
  Dim sCS     : sCS      = Join(Array( _
    "Provider=Microsoft.Jet.OLEDB.4.0", "Data Source=" & sSFSpec, _
    "Extended Properties=""Excel 8.0;HDR=True;IMEX=0;Readonly=False""" _
  ),";")
  WScript.Echo "Connectionstring:"
  WScript.Echo sCS
  oDbS.Open sCS
  Dim sInExt  : sInExt   = " IN """ & sDFSpec & """ ""Excel 8.0;"""

  Dim sSelI : sSelI = "SELECT * INTO [Tbl@Mod] " & sInExt & " FROM @Tbl WHERE [A] = '@Mod'"
  Dim sInsI : sInsI = "INSERT INTO [Tbl@Mod] " & sInExt & " SELECT * FROM @Tbl WHERE [A] = '@Mod'"
  WScript.Echo sSelI
  WScript.Echo sInsI

  Dim sMods : sMods = "SELECT [A] FROM " & aTblNs(0)
  Dim i
  For i = 1 TO UBound(aTblNs)
      sMods = sMods & " UNION SELECT [A] FROM " & aTblNs(i)
  Next
  sMods = sMods & " ORDER BY [A]"
  WScript.Echo sMods

  Dim oRS  : Set oRS = oDbS.Execute(sMods)
  Dim sSQL
  Do Until oRS.EOF
     WScript.Echo "Processing", oRS("A"), "..."
     sSQL = Replace(Replace(sSelI, "@Mod", oRS("A")), "@Tbl", aTblNs(0))
     WScript.Echo "Create & fill new table for", oRS("A")
     WScript.Echo sSQL
     oDbS.Execute sSQL
     For i = 1 To UBound(aTblNs)
         sSQL = Replace(Replace(sInsI, "@Mod", oRS("A")), "@Tbl", aTblNs(i))
         WScript.Echo "Appending for", oRS("A"), "from", aTblNs(i)
         WScript.Echo sSQL
         oDbS.Execute sSQL
     Next
     oRS.MoveNext
  Loop
  oRS.Close
  oDbS.Close

output:

输出：

Connectionstring:
Provider=Microsoft.Jet.OLEDB.4.0;Data Source=somewheresrc.xls;Extended
 Properties="Excel 8.0;HDR=True;IMEX=0;Readonly=False"
SELECT * INTO [Tbl@Mod]  IN "somewheredst.xls" "Excel 8.0;" FROM @Tbl
WHERE [A] = '@Mod'
INSERT INTO [Tbl@Mod]  IN "somewheredst.xls" "Excel 8.0;" SELECT * FRO
M @Tbl WHERE [A] = '@Mod'
SELECT [A] FROM [Tbl1] UNION SELECT [A] FROM [Tbl2] UNION SELECT [A] FROM [Tbl3] ORDER BY [A]
Processing Module1 ...
Create & fill new table for Module1
SELECT * INTO [TblModule1]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module1'
Appending for Module1 from [Tbl2]
INSERT INTO [TblModule1]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module1'
Appending for Module1 from [Tbl3]
INSERT INTO [TblModule1]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module1'
Processing Module2 ...
Create & fill new table for Module2
SELECT * INTO [TblModule2]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module2'
Appending for Module2 from [Tbl2]
INSERT INTO [TblModule2]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module2'
Appending for Module2 from [Tbl3]
INSERT INTO [TblModule2]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module2'
Processing Module3 ...
Create & fill new table for Module3
SELECT * INTO [TblModule3]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module3'
Appending for Module3 from [Tbl2]
INSERT INTO [TblModule3]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module3'
Appending for Module3 from [Tbl3]
INSERT INTO [TblModule3]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module3'
Processing Module4 ...
Create & fill new table for Module4
SELECT * INTO [TblModule4]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module4'
Appending for Module4 from [Tbl2]
INSERT INTO [TblModule4]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module4'
Appending for Module4 from [Tbl3]
INSERT INTO [TblModule4]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module4'

回答by Peter L.

Here is my approach: very straightforward and violates many programming principles, e.g. "avoid copy/paste usage", but from learning perspective it seems to be very easy to understand, and about 80% of code were generated using MacroRecorder. Here it is:

这是我的方法：非常简单，违反了许多编程原则，例如“避免使用复制/粘贴”，但从学习的角度来看，它似乎很容易理解，并且大约 80% 的代码是使用 MacroRecorder 生成的。这里是：

Sub DataToBook()

Dim CurDir As String
Dim ResultBook As String
Dim ResultRow As Long
Dim WS As Worksheet

Application.ScreenUpdating = False

CurDir = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "", vbTextCompare)
ResultBook = "Results.xlsx"
ResultRow = 1

Workbooks.Add
ActiveWorkbook.SaveAs Filename:=CurDir & ResultBook, FileFormat:= _
    xlOpenXMLWorkbook, CreateBackup:=False

For Each WS In ThisWorkbook.Worksheets

    ThisWorkbook.Activate
    WS.Select
    WS.Range("A1").Select
    WS.Rows("1:" & Selection.CurrentRegion.Rows.Count).Copy
    Workbooks(ResultBook).Sheets(1).Activate
    Workbooks(ResultBook).Sheets(1).Range("A1").Select
    If Selection.CurrentRegion.Rows.Count > 1 Then ResultRow = Selection.CurrentRegion.Rows.Count + 1
    Workbooks(ResultBook).Sheets(1).Cells(ResultRow, 1).Insert Shift:=xlDown

Next WS

Application.CutCopyMode = False

Workbooks(ResultBook).Sheets(1).Range("A1").Select
Workbooks(ResultBook).Sheets(1).Sort.SortFields.Clear
'
' Comment each of 3 lines below where sorting is not needed.
'
Workbooks(ResultBook).Sheets(1).Sort.SortFields.Add Key:=Range("A1:A" & Selection.CurrentRegion.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Workbooks(ResultBook).Sheets(1).Sort.SortFields.Add Key:=Range("B1:B" & Selection.CurrentRegion.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Workbooks(ResultBook).Sheets(1).Sort.SortFields.Add Key:=Range("C1:C" & Selection.CurrentRegion.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With Workbooks(ResultBook).Sheets(1).Sort
    .SetRange Selection.CurrentRegion
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Select
ActiveSheet.Range("A1").Select
Workbooks(ResultBook).Close SaveChanges:=True

Application.ScreenUpdating = True

End Sub

As a result, new workbook Results.xlsxwill be created in the same folder as source. Key points of my approach:

因此，Results.xlsx将在与源相同的文件夹中创建新工作簿。我的方法的要点：

1. Data is collected to new workbook using copy/paste of data regions of every original book sheet.
2. Key items are grouped using resulting array sort: my code uses all 3 columns for sorting, but to keep original order from source workbook one should just comment respective lines of code to disable sort settings.
3. Number of data keys and source book sheets is "unlimited" with such approach.

1. 使用每个原始书页的数据区域的复制/粘贴将数据收集到新工作簿中。
2. 关键项目使用结果数组排序进行分组：我的代码使用所有 3 列进行排序，但为了保持源工作簿的原始顺序，应该只注释相应的代码行以禁用排序设置。
3. 使用这种方法，数据键和源书页的数量是“无限的”。

Sample file is shared as well: https://www.dropbox.com/s/ual33s5me1gzhus/DataToBook.xlsm

示例文件也共享：https: //www.dropbox.com/s/ual33s5me1gzhus/DataToBook.xlsm

Hope that will be helpful somehow, at least in terms of learning of basic VBA coding.

希望这会有所帮助，至少在学习基本 VBA 编码方面是这样。

回答by Trace

I gave it another approach aside from SQL and sorts (already provided before).
I tested this code and it works.

除了 SQL 和排序（之前已经提供）之外，我还给了它另一种方法。
我测试了这段代码，它有效。

The general idea behind this code:

这段代码背后的总体思路：

1. Class module "clsSheet" contains all information per sheet, ie. column headers A, B, C, but also the used range, the array in which this range is loaded and the maximum row / col.
2. These self created data objects are loaded into a collection, after which the next part of the code will execute all code in memory (fast).
3. A dictionary is created and will contain the "module name" (ie. module1,2,3 etc...) as key, and a clsModule object as value. When a key (thus module name) does not exist yet, a new item will be added.
4. The clsModule class keeps the information on each modulename, ie. columns A, B and C information. The information is stored in the form of arrays.
5. When all information is stored in the dictionary, it is only a matter of translating the dictionary content back to a form that is preferred. In this case, I chose to give to each sheet the name of dictionary keys and load the data to their corresponding sheets.

1. 类模块“clsSheet”包含每张纸的所有信息，即。列标题 A、B、C，还有使用的范围、加载该范围的数组和最大行/列。
2. 这些自创建的数据对象被加载到一个集合中，之后代码的下一部分将执行内存中的所有代码（快速）。
3. 创建一个字典并将包含“模块名称”（即 module1,2,3 等...）作为键，并包含一个 clsModule 对象作为值。当一个键（即模块名称）尚不存在时，将添加一个新项目。
4. clsModule 类保存每个模块名的信息，即。A、B 和 C 列信息。信息以数组的形式存储。
5. 当所有信息都存储在字典中时，只需将字典内容翻译回首选形式即可。在这种情况下，我选择为每个工作表指定字典键的名称并将数据加载到相应的工作表中。

This code includes:

此代码包括：

• Dynamically finds headers with names "A", "B" and "C", which reduces risk for bugs;
• Fast execution;
• Creates a new workbook and writes the values for each "module" to a different sheet.
• These classes are re-usable in other situations with minimum modification needed.

• 动态查找名称为“A”、“B”和“C”的标题，从而降低出现错误的风险；
• 快速执行；
• 创建一个新工作簿并将每个“模块”的值写入不同的工作表。
• 这些类可以在其他情况下重用，只需要最少的修改。

The major benefit of this approach is flexibility. Since you load all data in a framework, you can virtually perform any actions afterwards by setting the classes and calling their properties.

这种方法的主要好处是灵活性。由于您在框架中加载所有数据，因此您可以通过设置类并调用它们的属性来执行任何操作。

Sub GetModules()


Dim cSheet                      As clsSheet
Dim cModule                     As clsModule
Dim oSheet                      As Excel.Worksheet
Dim oColl_Sheets                As Collection
Dim oDict                       As Object
Dim vTemp_Array_A               As Variant
Dim vTemp_Array_B               As Variant
Dim vTemp_Array_C               As Variant

Dim lCol_A                      As Long
Dim lCol_B                      As Long
Dim lCol_C                      As Long
Dim lMax_Row                    As Long
Dim lMax_Col                    As Long
Dim oRange                      As Range
Dim oRange_A                    As Range
Dim oRange_B                    As Range
Dim oRange_C                    As Range
Dim vArray                      As Variant

Dim lCnt                        As Long
Dim lCnt_Modules                As Long

Dim oBook                       As Excel.Workbook
Dim oSheet_Results              As Excel.Worksheet


Set oColl_Sheets = New Collection
Set oDict = CreateObject("Scripting.Dictionary")

'Get number of columns, rows and headers A, B, C dynamically
'This is useful in case columns are inserted
For Each oSheet In ThisWorkbook.Sheets

    Set cSheet = New clsSheet
    Set cSheet = cSheet.get_Sheet_Data(cSheet, oSheet)

    oColl_Sheets.Add cSheet

Next oSheet

'At this point, your entire sheet data structure is already contained in the collection oColl_Sheets

Set cSheet = Nothing

'Loop through the sheet objects and retrieve the values into modules
For Each cSheet In oColl_Sheets

    'Now you load back all data from the sheet and perform loops in memory through the arrays
    lCol_A = cSheet.fA_Col
    lCol_B = cSheet.fB_Col
    lCol_C = cSheet.fC_Col
    lMax_Row = cSheet.fMax_Row
    lMax_Col = cSheet.fMax_Col
    Set oRange = cSheet.fRange
    vArray = cSheet.fArray

    For lCnt = 1 To lMax_Row - 1

        'Check if the module already exists
        If Not oDict.Exists(vArray(1 + lCnt, 1)) Then  '+1 due to header
            lCnt_Modules = lCnt_Modules + 1
            Set cModule = New clsModule

            'Add to dictionary when new module (thus key) is new
            Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), True)
            Set cModule = cModule.Add_To_Array_B(cModule, lCol_B, vArray(1 + lCnt, lCol_B), True)
            Set cModule = cModule.Add_To_Array_C(cModule, lCol_C, vArray(1 + lCnt, lCol_C), True)

            oDict.Add vArray(1 + lCnt, 1), cModule

        Else

            Set cModule = oDict(vArray(1 + lCnt, 1))

            'Replace when module (thus key) already exists
            Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), False)
            Set cModule = cModule.Add_To_Array_B(cModule, lCol_A, vArray(1 + lCnt, lCol_B), False)
            Set cModule = cModule.Add_To_Array_C(cModule, lCol_A, vArray(1 + lCnt, lCol_C), False)

            Set oDict(vArray(1 + lCnt, 1)) = cModule

        End If

    Next lCnt

Next cSheet

'Now you have all the data available in your dictionary: per module (key), there is an array with the data you need.
'The only thing you have to do is open a new workbook and paste the data there.
'Below an example how you can paste the results per worksheet

Set oBook = Workbooks.Add
Set oSheet_Results = oBook.Sheets(1)

lCnt = 0
For lCnt = 0 To oDict.Count - 1

    'Fill in values from dictionary
    oBook.Sheets.Add().Name = oDict.Keys()(lCnt)
    ReDim vTemp_Array_A(1 To UBound(oDict.Items()(lCnt).fA_Arr))
    ReDim vTemp_Array_B(1 To UBound(oDict.Items()(lCnt).fB_Arr))
    ReDim vTemp_Array_C(1 To UBound(oDict.Items()(lCnt).fC_Arr))
    oBook.Sheets(oDict.Keys()(lCnt)).Range("A1").Value = "A"
    oBook.Sheets(oDict.Keys()(lCnt)).Range("B1").Value = "B"
    oBook.Sheets(oDict.Keys()(lCnt)).Range("C1").Value = "C"

    vTemp_Array_A = oDict.Items()(lCnt).fA_Arr
    vTemp_Array_B = oDict.Items()(lCnt).fB_Arr
    vTemp_Array_C = oDict.Items()(lCnt).fC_Arr
    Set oRange_A = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 1), Cells(1 + UBound(vTemp_Array_A), 1))
    Set oRange_B = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 2), Cells(1 + UBound(vTemp_Array_B), 2))
    Set oRange_C = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 3), Cells(1 + UBound(vTemp_Array_C), 3))
    oRange_A = Application.Transpose(vTemp_Array_A)
    oRange_B = Application.Transpose(vTemp_Array_B)
    oRange_C = Application.Transpose(vTemp_Array_C)

Next lCnt

Set oColl_Sheets = Nothing
Set oRange = Nothing
Set oDict = Nothing

End Sub

Class module called "clsModule"

名为“clsModule”的类模块

Option Explicit

Private pModule_Nr              As Long
Private pA_Arr                  As Variant
Private pB_Arr                  As Variant
Private pC_Arr                  As Variant

Public Function Add_To_Array_A(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule

Dim vArray As Variant

vArray = cModule.fA_Arr

If bNew Then
    ReDim vArray(1 To 1)
    vArray(1) = vValue
Else
    ReDim Preserve vArray(1 To UBound(vArray) + 1)
    vArray(UBound(vArray)) = vValue
End If

cModule.fA_Arr = vArray

Set Add_To_Array_A = cModule

End Function

Public Function Add_To_Array_B(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule

Dim vArray As Variant

vArray = cModule.fB_Arr

If bNew Then
    ReDim vArray(1 To 1)
    vArray(1) = vValue
Else
    ReDim Preserve vArray(1 To UBound(vArray) + 1)
    vArray(UBound(vArray)) = vValue
End If

cModule.fB_Arr = vArray

Set Add_To_Array_B = cModule

End Function

Public Function Add_To_Array_C(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule

Dim vArray As Variant

vArray = cModule.fC_Arr

If bNew Then
    ReDim vArray(1 To 1)
    vArray(1) = vValue
Else
    ReDim Preserve vArray(1 To UBound(vArray) + 1)
    vArray(UBound(vArray)) = vValue
End If

cModule.fC_Arr = vArray

Set Add_To_Array_C = cModule

End Function


Property Get fModule_Nr() As Long
    fModule_Nr = pModule_Nr
End Property

Property Let fModule_Nr(lModule_Nr As Long)
    pModule_Nr = lModule_Nr
End Property

Property Get fA_Arr() As Variant
    fA_Arr = pA_Arr
End Property

Property Let fA_Arr(vA_Arr As Variant)
    pA_Arr = vA_Arr
End Property

Property Get fB_Arr() As Variant
    fB_Arr = pB_Arr
End Property

Property Let fB_Arr(vB_Arr As Variant)
    pB_Arr = vB_Arr
End Property

Property Get fC_Arr() As Variant
    fC_Arr = pC_Arr
End Property

Property Let fC_Arr(vC_Arr As Variant)
    pC_Arr = vC_Arr
End Property

Class module called "clsSheet"

名为“clsSheet”的类模块

Option Explicit
Private pMax_Col                As Long
Private pMax_Row                As Long
Private pArray                  As Variant
Private pRange                  As Range
Private pA_Col                  As Long
Private pB_Col                  As Long
Private pC_Col                  As Long

Public Function get_Sheet_Data(cSheet As clsSheet, oSheet As Excel.Worksheet) As clsSheet

Dim oUsed_Range         As Range
Dim lLast_Col           As Long
Dim lLast_Row           As Long
Dim iCnt                As Integer
Dim vArray              As Variant
Dim lNr_Rows            As Long
Dim lNr_Cols            As Long

Dim lCnt                As Long


With oSheet
    lLast_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
    lLast_Col = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

oSheet.Activate
Set oUsed_Range = oSheet.Range(Cells(1, 1), Cells(lLast_Row, lLast_Col))
cSheet.fRange = oUsed_Range
lNr_Rows = oUsed_Range.Rows.Count
cSheet.fMax_Row = lNr_Rows
lNr_Cols = oUsed_Range.Columns.Count
cSheet.fMax_Col = lNr_Cols
ReDim vArray(1 To lNr_Rows, 1 To lNr_Cols)
vArray = oUsed_Range
cSheet.fArray = vArray

For lCnt = 1 To lNr_Cols
    Select Case vArray(1, lCnt)

        Case "A"
            cSheet.fA_Col = lCnt
        Case "B"
            cSheet.fB_Col = lCnt
        Case "C"
            cSheet.fC_Col = lCnt

    End Select
Next lCnt

Set get_Sheet_Data = cSheet

End Function

Property Get fMax_Col() As Long
    fMax_Col = pMax_Col
End Property

Property Let fMax_Col(lMax_Col As Long)
    pMax_Col = lMax_Col
End Property

Property Get fMax_Row() As Long
    fMax_Row = pMax_Row
End Property

Property Let fMax_Row(lMax_Row As Long)
    pMax_Row = lMax_Row
End Property

Property Get fRange() As Range
    Set fRange = pRange
End Property

Property Let fRange(oRange As Range)
    Set pRange = oRange
End Property

Property Get fArray() As Variant
    fArray = pArray
End Property

Property Let fArray(vArray As Variant)
    pArray = vArray
End Property

Property Get fA_Col() As Long
    fA_Col = pA_Col
End Property

Property Let fA_Col(lA_Col As Long)
    pA_Col = lA_Col
End Property

Property Get fB_Col() As Long
    fB_Col = pB_Col
End Property

Property Let fB_Col(lB_Col As Long)
    pB_Col = lB_Col
End Property

Property Get fC_Col() As Long
    fC_Col = pC_Col
End Property

Property Let fC_Col(lC_Col As Long)
    pC_Col = lC_Col
End Property

回答by Warlord

@Peter L, @Kim Gysen & @Ekkehard.Horner, Thanks guys for all the codes that you guys gave. But the code is way above my head. How ever i did solve this issue. I just copied all the data from all the sheets into the new excel book and just sorted the entire data based on Modules. So i was able to get the solution.

@Peter L、@Kim Gysen 和 @Ekkehard.Horner，感谢你们提供的所有代码。但是代码远在我的头上。我是如何解决这个问题的。我只是将所有工作表中的所有数据复制到新的 excel 书中，并根据模块对整个数据进行排序。所以我能够得到解决方案。

Sub CopyRawData()
countSheet = RawData.Sheets.Count
For i = 1 to countSheet     
    RawData.Activate
    name = RawData.Sheets(i).Name

    RawData.WorkSheets(name).Select
    RawData.Worksheets(name).Range("A2").Select

    objExcel.ActiveSheet.UsedRange.Select
    usedRowCount1 = objExcel.Selection.Rows.Count
    objExcel.Range("A2:J" & usedRowCount1).Copy

    RawData.WorkSheets(name).Select
    RowCount = objExcel.Selection.Rows.Count
    RawData.Worksheets(name).Range("F2").Select

    FinalReport.Activate
    FinalReport.WorkSheets("Results").Select
    objExcel.ActiveSheet.UsedRange.Select
    usedRowCount2= objExcel.Selection.Rows.Count

    FinalReport.Worksheets("Results").Range("A"& usedRowCount2 + 1 ).PasteSpecial Paste =xlValues

Next
FinalReport.Save                        

Sub CopyData()
    Const xlAscending = 1
    Const xlDescending = 2
    Const xlYes = 1
    Set objRange = FinalReport.Worksheets("Results").UsedRange
    Set objRange2 = objExcel.Range("C2")
    objRange.Sort objRange2, xlAscending, , , , , , xlYes
End Sub