从字典中插入数据不正确
Incorrect insertion of data from the dictionary
我有 Excel 数据。
我写了一个代码，允许我根据公司过滤数据。
Sub testProjectMl()
Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
Dim i As Long, arrA, dictKP As Object
'Create a variable
Dim dictKS
Dim dictVT
Dim dictAK
Dim dictPP
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
firstRow = 8 'first row with data
arrA = sh.Range("A" & firstRow & ":A" & lastRow).Value 'place the range in an array for faster iteration
Set dictKP = CreateObject("Scripting.Dictionary")
Set dictKS = CreateObject("Scripting.Dictionary")
Set dictVT = CreateObject("Scripting.Dictionary")
Set dictPP = CreateObject("Scripting.Dictionary")
Set dictAK = CreateObject("Scripting.Dictionary")
With Sheets(ActiveSheet.Name)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 8 To lastRow
If IsNumeric(.Range("H" & i)) And Trim(.Range("H" & i).Value) <> "" And .Range("H" & i).Value <> 0 And .Range("H" & i).Value > 7000 Then
Select Case True
Case .Range("A" & i).Value Like "KP*"
dictKP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "KS*"
dictKS.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "VT*"
dictVT.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "PP*"
dictPP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "AK*"
dictAK.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
End Select
End If
Next i
End With
Sheets.Add.Name = "KP"
Sheets.Add.Name = "KS"
Sheets.Add.Name = "VT"
Sheets.Add.Name = "PP"
Sheets.Add.Name = "AK"
Set shDestKp = Sheets("KP")
Set shDestKs = Sheets("KS")
Set shDestVt = Sheets("VT")
Set shDestPp = Sheets("PP")
Set shDestAk = Sheets("AK")
For i = 0 To dictKP.Count - 1
lastERowDest = shDestKp.Range("A" & shDestKp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKP.items()(i).Copy shDestKp.Range("A" & lastERowDest)
shDestKp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKp.Range("K" & lastERowDest).Copy ' copy the target format
shDestKp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictKS.Count - 1
lastERowDest = shDestKs.Range("A" & shDestKs.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKS.items()(i).Copy shDestKs.Range("A" & lastERowDest)
shDestKs.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKs.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKs.Range("K" & lastERowDest).Copy ' copy the target format
shDestKs.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKs.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKs.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictVT.Count - 1
lastERowDest = shDestVt.Range("A" & shDestVt.Rows.Count).End(xlUp).Row + 1
'If lastERowDest = 2 Then lastERowDest = 1
dictVT.items()(i).Copy shDestVt.Range("A" & lastERowDest)
shDestVt.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestVt.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestVt.Range("K" & lastERowDest).Copy ' copy the target format
shDestVt.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestVt.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestVt.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictPP.Count - 1
lastERowDest = shDestPp.Range("A" & shDestPp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictPP.items()(i).Copy shDestPp.Range("A" & lastERowDest)
shDestPp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestPp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestPp.Range("K" & lastERowDest).Copy ' copy the target format
shDestPp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestPp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestPp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictAK.Count - 1
lastERowDest = shDestAk.Range("A" & shDestAk.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictAK.items()(i).Copy shDestAk.Range("A" & lastERowDest)
shDestAk.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestAk.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestAk.Range("K" & lastERowDest).Copy ' copy the target format
shDestAk.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestAk.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestAk.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
End Sub
如您所见，根据单元格 A 开头的值，我在某个字典中添加了行。然后每个字典都有一个循环，并将值插入特定的 sheets.
但是我有一个问题，由于某种原因，在遍历字典时在所有 sheet 中输入了同一行。
例如(KS sheet):
此 sheet 应具有以下值：
当Select大小写并向字典中添加一行时，单元格A中的值被正确指定并且对应于特定字典。但是我不明白为什么在遍历字典时，会插入 dictKP 字典中的相同值。
示例到底需要什么：
请尝试使用下一个代码。它 只需要一个字典，根据前两个公司名称字符创建键 。它将根据字典键添加新工作表并清除现有工作表（如果存在）：
Sub testProjectMl()
Dim sh As Worksheet, newSh As Worksheet, lastRow As Long, firstRow As Long
Dim i As Long, arrA, minVal As Double, dict As Object
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
firstRow = 7 'the row where the headers exist
minVal = 7000 'you can change it (if another limit would be necessary)...
arrA = sh.Range("A" & firstRow & ":K" & lastRow).value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrA) 'iterate between the array rows:
If IsNumeric(arrA(i, 8)) And Trim(arrA(i, 8)) <> "" And arrA(i, 8) <> 0 And arrA(i, 8) > minVal Then
If Not dict.Exists(left(arrA(i, 1), 2)) Then
dict.Add left(arrA(i, 1), 2), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
Else
Set dict(left(arrA(i, 1), 2)) = Union(dict(left(arrA(i, 1), 2)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
End If
End If
Next i
'drop the dictionary items content in the appropriate sheet (add it if not existing):
Application.ScreenUpdating = False 'to make the code faster, when inserts sheet and copy ranges...
Application.EnableEvents = False
For i = 0 To dict.count - 1
If Not sheetExists(CStr(dict.Keys()(i))) Then
Set newSh = ActiveWorkbook.Sheets.Add(After:=sh) 'insert the sheet if it does not exist
newSh.name = dict.Keys()(i)
Else
Set newSh = ActiveWorkbook.Sheets(dict.Keys()(i))'set the existing sheet and clear its content
newSh.cells.ClearContents
End If
dict.items()(i).Copy newSh.Range("A1") 'copy the dictionary range
Next i
End Sub
Function sheetExists(shName As String) As Boolean
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name = shName Then sheetExists = True: Exit Function
Next ws
End Function
我有 Excel 数据。
我写了一个代码，允许我根据公司过滤数据。
Sub testProjectMl()
Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
Dim i As Long, arrA, dictKP As Object
'Create a variable
Dim dictKS
Dim dictVT
Dim dictAK
Dim dictPP
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
firstRow = 8 'first row with data
arrA = sh.Range("A" & firstRow & ":A" & lastRow).Value 'place the range in an array for faster iteration
Set dictKP = CreateObject("Scripting.Dictionary")
Set dictKS = CreateObject("Scripting.Dictionary")
Set dictVT = CreateObject("Scripting.Dictionary")
Set dictPP = CreateObject("Scripting.Dictionary")
Set dictAK = CreateObject("Scripting.Dictionary")
With Sheets(ActiveSheet.Name)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 8 To lastRow
If IsNumeric(.Range("H" & i)) And Trim(.Range("H" & i).Value) <> "" And .Range("H" & i).Value <> 0 And .Range("H" & i).Value > 7000 Then
Select Case True
Case .Range("A" & i).Value Like "KP*"
dictKP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "KS*"
dictKS.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "VT*"
dictVT.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "PP*"
dictPP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "AK*"
dictAK.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
End Select
End If
Next i
End With
Sheets.Add.Name = "KP"
Sheets.Add.Name = "KS"
Sheets.Add.Name = "VT"
Sheets.Add.Name = "PP"
Sheets.Add.Name = "AK"
Set shDestKp = Sheets("KP")
Set shDestKs = Sheets("KS")
Set shDestVt = Sheets("VT")
Set shDestPp = Sheets("PP")
Set shDestAk = Sheets("AK")
For i = 0 To dictKP.Count - 1
lastERowDest = shDestKp.Range("A" & shDestKp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKP.items()(i).Copy shDestKp.Range("A" & lastERowDest)
shDestKp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKp.Range("K" & lastERowDest).Copy ' copy the target format
shDestKp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictKS.Count - 1
lastERowDest = shDestKs.Range("A" & shDestKs.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKS.items()(i).Copy shDestKs.Range("A" & lastERowDest)
shDestKs.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKs.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKs.Range("K" & lastERowDest).Copy ' copy the target format
shDestKs.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKs.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKs.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictVT.Count - 1
lastERowDest = shDestVt.Range("A" & shDestVt.Rows.Count).End(xlUp).Row + 1
'If lastERowDest = 2 Then lastERowDest = 1
dictVT.items()(i).Copy shDestVt.Range("A" & lastERowDest)
shDestVt.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestVt.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestVt.Range("K" & lastERowDest).Copy ' copy the target format
shDestVt.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestVt.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestVt.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictPP.Count - 1
lastERowDest = shDestPp.Range("A" & shDestPp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictPP.items()(i).Copy shDestPp.Range("A" & lastERowDest)
shDestPp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestPp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestPp.Range("K" & lastERowDest).Copy ' copy the target format
shDestPp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestPp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestPp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictAK.Count - 1
lastERowDest = shDestAk.Range("A" & shDestAk.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictAK.items()(i).Copy shDestAk.Range("A" & lastERowDest)
shDestAk.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestAk.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestAk.Range("K" & lastERowDest).Copy ' copy the target format
shDestAk.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestAk.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestAk.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
End Sub
如您所见，根据单元格 A 开头的值，我在某个字典中添加了行。然后每个字典都有一个循环，并将值插入特定的 sheets.
但是我有一个问题，由于某种原因，在遍历字典时在所有 sheet 中输入了同一行。
例如(KS sheet):
此 sheet 应具有以下值：
当Select大小写并向字典中添加一行时，单元格A中的值被正确指定并且对应于特定字典。但是我不明白为什么在遍历字典时，会插入 dictKP 字典中的相同值。
示例到底需要什么：
请尝试使用下一个代码。它 只需要一个字典，根据前两个公司名称字符创建键 。它将根据字典键添加新工作表并清除现有工作表（如果存在）：
Sub testProjectMl()
Dim sh As Worksheet, newSh As Worksheet, lastRow As Long, firstRow As Long
Dim i As Long, arrA, minVal As Double, dict As Object
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
firstRow = 7 'the row where the headers exist
minVal = 7000 'you can change it (if another limit would be necessary)...
arrA = sh.Range("A" & firstRow & ":K" & lastRow).value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrA) 'iterate between the array rows:
If IsNumeric(arrA(i, 8)) And Trim(arrA(i, 8)) <> "" And arrA(i, 8) <> 0 And arrA(i, 8) > minVal Then
If Not dict.Exists(left(arrA(i, 1), 2)) Then
dict.Add left(arrA(i, 1), 2), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
Else
Set dict(left(arrA(i, 1), 2)) = Union(dict(left(arrA(i, 1), 2)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
End If
End If
Next i
'drop the dictionary items content in the appropriate sheet (add it if not existing):
Application.ScreenUpdating = False 'to make the code faster, when inserts sheet and copy ranges...
Application.EnableEvents = False
For i = 0 To dict.count - 1
If Not sheetExists(CStr(dict.Keys()(i))) Then
Set newSh = ActiveWorkbook.Sheets.Add(After:=sh) 'insert the sheet if it does not exist
newSh.name = dict.Keys()(i)
Else
Set newSh = ActiveWorkbook.Sheets(dict.Keys()(i))'set the existing sheet and clear its content
newSh.cells.ClearContents
End If
dict.items()(i).Copy newSh.Range("A1") 'copy the dictionary range
Next i
End Sub
Function sheetExists(shName As String) As Boolean
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name = shName Then sheetExists = True: Exit Function
Next ws
End Function