我在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
答案 0 :(得分:2)
而不是让流行的“你有什么尝试?”强迫你写作 没有计划的代码,考虑(并要求)知道/知道/方法/工具 将特定行的纸张/表格选择到新的纸张/表格中所必需的。
“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'
答案 1 :(得分:0)
这是我的方法:非常简单并且违反了许多编程原则,例如: “避免复制/粘贴使用”,但从学习角度看,它似乎很容易理解,大约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
。我的方法的关键点:
示例文件也是共享的:https://www.dropbox.com/s/ual33s5me1gzhus/DataToBook.xlsm
希望以某种方式提供帮助,至少在学习基本的VBA编码方面。
答案 2 :(得分:0)
除了SQL和排序(之前已提供)之外,我给了它另一种方法 我测试了这段代码并且它有效。
此代码背后的一般理念:
此代码包括:
这种方法的主要好处是灵活性。由于您在框架中加载所有数据,因此可以通过设置类并调用其属性来虚拟地执行任何操作。
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
答案 3 :(得分:0)
@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