根据特定的单元格值从Excel中复制特定的行

我有一个Excel书中的多个工作表，每个这些工作表包含模块明智的数据。 我想复制每个工作表中的所有模块数据，并将其粘贴到新的excel书籍中。 这怎么能用VBScript来完成？

所有工作表在rawData.xls中看起来都是这样的

ABC 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

而不是让stream行的“你试过什么？ 强迫你在没有计划的情况下编写代码，考虑（并要求）select特定的表/表格到新的工作表/表中的方法/工具。

“select”意味着SQL，而Excel不是数据库pipe理系统，可以使用.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）对于每个Module1 … ModuleLast

（5a）要为目标.XLS中的模块M创build新的工作表/表，请执行类似下面的语句：

 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

这是我的方法：非常简单，违反了许多编程原则，例如“避免复制/粘贴使用”，但从学习的angular度来看，它似乎很容易理解，大约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将在与源文件相同的文件夹中创build。 我的方法要点：

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

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

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

Answer 3

除了SQL和sorting（之前已经提供）之外，我给了它另外一个方法。
我testing了这个代码，它的工作原理。

这个代码背后的一般理念：

1. 类模块“clsSheet”包含每张表的所有信息，即。 列标题A，B，C，还包括已使用的范围，加载该范围的数组以及最大的行/列。
2. 这些自创的数据对象被加载到一个集合中，之后的代码的下一部分将执行内存中的所有代码（快速）。
3. 一个字典被创build并将包含“模块名称”（即module1,2,3 etc …）作为关键字，并将一个clsModule对象作为值。 当一个密钥（因此模块名称）不存在，一个新的项目将被添加。
4. clsModule类保持每个模块名称的信息，即。 列A，B和C信息。 信息以数组的forms存储。
5. 当所有信息都存储在字典中时，只是将字典内容翻译成首选的forms。 在这种情况下，我select给每张纸上的字典键的名称，并将数据加载到相应的表。

此代码包括：

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

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

 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 

称为“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 

称为“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 

Answer 4

@Peter L，@Kim Gysen＆@ Ekkehard.Horner，谢谢你们给出的所有代码。 但代码是高于我的头。 我怎么解决这个问题。 我只是将所有表单中的所有数据复制到新的excel书籍中，并根据模块对整个数据进行sorting。 所以我能够得到解决scheme。

 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