Question

我在Excel工作簿中有多个工作表，每个工作表都包含模块智能数据。我想从每个工作表中复制所有模块数据并将其粘贴到新的Excel工作簿中。如何使用 VBScript ？

完成此操作

所有工作表在 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

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

有没有办法使用VB脚本实现这种自动化？

感谢任何帮助。提前致谢

我的代码：

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

Answer 1

而不是让流行的“你有什么尝试？”强迫你写作没有计划的代码，考虑（并要求）知道/知道/方法/工具将特定行的纸张/表格选择到新的纸张/表格中所必需的。

“select”表示SQL，而Excel不是数据库管理系统，您可以使用.XLS作为数据库：在ADO的帮助下。

所以我的计划是：

（1）打开一个ADODB.Connection来源.XLS

（2）获取要处理的所有工作表/表的列表

（3）使用（2）生成类似

的语句

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

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

（5）For Each Module1 ... ModuleLast

（5a）要在目标.XLS中为模块M创建新工作表/表，请执行类似

的语句

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

（5b）对于每个Tbl2 ... TblLast使用类似

的语句追加ModuleM行

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

演示代码可让您对计划有所信心，并可查找一些关键字：

  Const csSFSpec   = "..\data\14515369\src.xls"
  Const csDFSpec   = "..\data\14515369\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

输出：

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'

Answer 2

这是我的方法：非常简单并且违反了许多编程原则，例如： “避免复制/粘贴使用”，但从学习角度看，它似乎很容易理解，大约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

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

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

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

希望以某种方式提供帮助，至少在学习基本的VBA编码方面。

Answer 3

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

此代码背后的一般理念：

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

此代码包括：

动态查找名称为＆＃34; A＆＃34;，＆＃34; B＆＃34;和＆＃34; C＆＃34;，它可以降低漏洞的风险;
快速执行;
创建一个新工作簿并为每个＆＃34;模块＆＃34;写入值。到另一张纸。
这些类在其他情况下可重复使用，只需要进行最少的修改。

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

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

类模块叫＆＃34; clsModule＆＃34;

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

类模块名为＆＃34; clsSheet＆＃34;

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

Answer 4

@Peter L，@ Kim Gysen＆amp; @ 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

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

4 个答案: