我试图遍历一列并获取单元格中的值。该值是唯一的代码，仅在第一张纸上出现一次。
当我得到一个值时，它可能是第一个单元格，我想遍历工作表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 '''
答案 0 :(得分：1)
在循环中使用Dictionary Object而不是循环。
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 '''