excel - 一次循环遍历多张工作表
问题描述
我正在尝试遍历一列并获取单元格中的值。该值是唯一代码,并且仅在第一张纸上出现一次。
当我得到一个值时,它可能是第一个单元格,我想浏览表 4 中的一列。唯一代码可以在表 4 上出现多次。
我想将表 1 中的代码与表 4 中的代码匹配。如果代码匹配,我想将列值保存在行索引上并将其插入到一个全新的工作簿中。
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
Const WB_OUTPUT = "MyResult.xlsx"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, sKey As String, ar As Variant
Set dict = CreateObject("Scripting.Dictionary")
' build dictionary from sheet4 of code to rows number
iLastRow = ws4.Cells(Rows.count, CODE_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, CODE_SHT4)
If dict.exists(sKey) Then
dict(sKey) = dict(sKey) & ";" & iRow ' matched row on sheet 1
Else
dict(sKey) = iRow
End If
Next
' scan down sheet1
count = 0: countWB = 0
iRow = START_ROW
Do Until (ws1.Cells(iRow, CODE_SHT1) = "END") Or (iRow > MAX_ROW)
sKey = ws1.Cells(iRow, CODE_SHT1)
If dict.exists(sKey) Then
' rows on sheet4 to copy
ar = Split(dict(sKey), ";")
'create new workbook and copy rows
Dim Pheight As Integer
Pheight = 25000
Set WkSht_Src = ThisWorkbook.Worksheets(2)
Set Rng = WkSht_Src.Range(ThisWorkbook.Worksheets(2).Cells(1, 1), ThisWorkbook.Worksheets(2).Cells(Pheight, 48))
Set WkBk_Dest = Application.Workbooks.Add
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
Rng.Copy
WkSht_Dest.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Rng.Copy
WkSht_Dest.Range("A1").PasteSpecial xlPasteFormats
WkSht_Src.Pictures(1).Copy
WkSht_Dest.Range("A1").PasteSpecial
WkSht_Dest.Pictures(1).Top = 5
WkSht_Dest.Pictures(1).Left = 0
iTargetRow = 11
Set wsNew = WkSht_Dest
Set wbNew = WkBk_Dest
For i = LBound(ar) To UBound(ar)
iCopyRow = ar(i)
iTargetRow = iTargetRow + 1
' copy selected cols to new workbook
ws4.Range("C" & iCopyRow).Resize(1, 5).Copy wsNew.Range("A" & iTargetRow)
count = count + 1
Next
wbNew.SaveAs sKey & ".xlsx"
wbNew.Close
countWB = countWB + 1
End If
iRow = iRow + 1
Loop
MsgBox dict.count & " keys in dictionary ", vbInformation
msg = iLastRow & " rows scanned on sheet4 " & vbCr & _
count & " rows copied to " & countWB & " new workbooks"
MsgBox msg, vbInformation
End Sub '''
解决方案
使用字典对象而不是循环中的循环。
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
' build dictionary from sheet4 of code to rows number
iLastRow = ws4.Cells(Rows.count, CODE_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, CODE_SHT4)
If dict.exists(sKey) Then
dict(sKey) = dict(sKey) & ";" & iRow ' matched row on sheet 1
Else
dict(sKey) = iRow
End If
Next
' build dictCVR from sheet3
iLastRow = ws3.Cells(Rows.count, CVR_SHT3).End(xlUp).Row
For iRow = 18 To iLastRow
sKey = ws3.Cells(iRow, CVR_SHT3)
If dictCVR.exists(sKey) Then
dictCVR(sKey) = dictCVR(sKey) & ";" & iRow
Else
dictCVR(sKey) = iRow
End If
Next
' scan down sheet1
count = 0: countWB = 0
iRow = START_ROW
Do Until (ws1.Cells(iRow, CODE_SHT1) = "END") Or (iRow > MAX_ROW)
sKey = ws1.Cells(iRow, CODE_SHT1)
If dict.exists(sKey) Then
' rows on sheet4 to copy
ar = Split(dict(sKey), ";")
'create new workbook and copy rows
Set WkSht_Src = wb.Worksheets(2)
Set Rng = WkSht_Src.Range("A1:AV25000")
Set WkBk_Dest = Application.Workbooks.Add
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
With WkSht_Dest
Rng.Copy
.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
.Range("A1").PasteSpecial xlPasteFormats
WkSht_Src.Pictures(1).Copy
.Range("A1").PasteSpecial
.Pictures(1).Top = 5
.Pictures(1).Left = 0
End With
Application.CutCopyMode = False
iTargetRow = 11
Set wsNew = WkSht_Dest
Set wbNew = WkBk_Dest
For i = LBound(ar) To UBound(ar)
iCopyRow = ar(i)
iTargetRow = iTargetRow + 1
' copy selected cols to new workbook
ws4.Range("C" & iCopyRow).Resize(1, 5).Copy wsNew.Range("A" & iTargetRow)
' add cvr records from sheet3 it any
sCVR = ws4.Cells(iCopyRow, CVR_SHT4)
If dictCVR.exists(sCVR) Then
arCVR = Split(dictCVR(sCVR), ";")
For j = LBound(arCVR) To UBound(arCVR)
If j > 0 Then iTargetRow = iTargetRow + 1
' copy col A to P
iCopyRow = arCVR(j)
Debug.Print sCVR, j, iCopyRow
ws3.Range("A" & iCopyRow).Resize(1, 16).Copy wsNew.Range("E" & iTargetRow)
count = count + 1
Next
Else
count = count + 1
End If
Next
wbNew.SaveAs sKey & ".xlsx"
wbNew.Close
countWB = countWB + 1
End If
iRow = iRow + 1
Loop
msg = dict.count & " keys in CODE dictionary" & vbCr & _
dictCVR.count & " keys in CVR dictionary"
MsgBox msg, vbInformation
msg = iLastRow & " rows scanned on sheet4 " & vbCr & _
count & " rows copied to " & countWB & " new workbooks"
MsgBox msg, vbInformation
End Sub '''
推荐阅读
- sql-server - 从非结构化数据中检索数据
- javascript - 连接 JSON 表输出中的两个字段
- python - 通过交叉验证计算 AUC 95 % CI (Python, sklearn)
- ethernet - 不同速度以太网接口的电压电平调制
- python-3.x - 如何检查列是否为二进制?(熊猫)
- node.js - 尝试创建将启动提到的节点应用程序的单个 bash 文件
- php - Laravel:无法检索一对多camelCase方法
- python-3.x - 使用python在特定区域擦除或清除使用pythonqt5绘制的Qcolor或填充多边形颜色
- azure-devops - 在服务器上安装部署 azure 代理失败:System.IO.FileNotFoundException:无法加载文件或程序集 'DotNetAgent,版本 = 1.0.0.0
- bash - 即使对于单行输入,unix 的“读取”命令也无法在没有 while 循环的情况下工作