1
私は2つのワークシートを持っています：変数はセルからデータを削除しています - ループヘルプ。 VBA
a）すべてのフィクスチャコンポーネントを含むフィクスチャリスト。
b）フィクスチャを持つストアを持つストアリスト。
c）私が必要とするもの - フィクスチャを持つフィクスチャのリスト、フィクスチャを持つストアも表示されます。
2つのワークシートを組み合わせた第3のワークシートを作成する必要があります。現在私は、フィクスチャの名前を探すfind関数を持っています。必要な情報に基づいて変数を作成し、変数を3番目のシートに配置します。
しかし、元の変数情報を設定すると、変数名が消えてしまいます。そのため、次のループでは、フィクスチャ名が検索で捕捉されません。
ストアリストが大量になり、マクロの実行が非常に遅くなります。それをより効率的にするための助けとなるでしょう。
私はこれをうまく説明していないので、自分のコードを添付しました。ここで
Sub FindTest()
Dim S1 As Excel.Worksheet
Dim S2 As Excel.Worksheet
Dim S3 As Excel.Worksheet
Dim h As Long
Dim i As Long
Dim j As Long
Dim x As Long
Dim l As Long
Dim aCell As Range
Dim bCell As Range
Dim oRange As Range
Dim TitleVar As String
Dim ItemNumber As String
Dim ItemDesc As String
Dim ShipTo As String
Dim StoreNumber As String
Dim UPC As String
Dim Chain As String
Dim DivRange As Range
Dim Match As String
Dim FixtureType As String
Dim FindFixtureName As Range
Dim FindItemNumber As Range
Dim FindUPC As Range
Dim FindItemDesc As Range
Dim lastRow As Integer
Dim rng As Range
Dim wb As Workbook
Dim rng1 As Range
Set S1 = Sheets("Titles")
Set S2 = Sheets("Fixtures")
Set S3 = Sheets("Import")
Set wb = ActiveWorkbook
Set rng1 = S1.Cells.Find("*", S1.[a1], xlFormulas, , , xlPrevious)
Set oRange = S1.Columns(4)
h = 2
j = 2
i = 2
K = 2
l = 2
m = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Activate
S2.Columns("B:B").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
TitleVar = S1.Cells(K, 4)
Chain = S2.Cells(h, 1)
ShipTo = S2.Cells(h, 2)
StoreNumber = S2.Cells(h, 4)
UPC = Format(S1.Cells(K, 7), "###########")
lastRow = S1.Range("D" & Rows.Count).End(xlUp).Row
StrSearch = UCase(S2.Cells(h, 6))
FixtureType = S2.Cells(h, 8)
ItemNumber = S1.Range("D" & i).Offset(0, 2)
Match = ShipTo & ItemNumber
'************** Test Worksheet
LastShipTo = S2.Range("B" & Rows.Count).End(xlUp).Row - 1
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Test"
Range("A1") = "Chain"
Range("B1") = "Match"
Range("C1") = "Ship To Number"
Range("D1") = "Store #"
Range("E1") = "Item Number"
Range("F1") = "Item Description"
Range("G1") = "UPC"
Range("H1") = "Fixture"
Range("I1") = "Fixture Type"
Range("j1") = "Division"
Range("k1") = "Total"
Range("A1:Q1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6299648
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Range("A1:K1").HorizontalAlignment = xlCenter
Set FindFixtureName = S1.Range("D:D").Find(What:=StrSearch,
After:=S1.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Do While FindFixtureName Is Nothing
If FindFixtureName Is Nothing Then
h = h + 1
StrSearch = UCase(S2.Cells(h, 6))
Set FindFixtureName = S1.Range("D:D").Find(What:=StrSearch,
After:=S1.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
End If
Loop
Set FindItemNumber = S1.Range("D:D").Find(What:=StrSearch,
After:=S1.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0,
2) Set FindUPC = S1.Range("D:D").Find(What:=StrSearch, After:=S1.Cells(1,
4), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:=False).Offset(0, 3)
Set FindItemDesc = S1.Range("D:D").Find(What:=StrSearch, After:=S1.Cells(1,
4), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:=False).Offset(0, 4)
Do Until StrSearch = ""
Do Until FindFixtureName <> StrSearch
Match = ShipTo & FindItemNumber
Sheets("Test").Cells(j, 1) = Chain
Sheets("Test").Cells(j, 2) = Match
Sheets("Test").Cells(j, 3) = ShipTo
Sheets("Test").Cells(j, 4) = StoreNumber
Sheets("Test").Cells(j, 5) = FindItemNumber
Sheets("Test").Cells(j, 6) = FindItemDesc
Sheets("Test").Cells(j, 7) = FindUPC
Sheets("Test").Cells(j, 8) = StrSearch
Sheets("Test").Cells(j, 9) = FixtureType
j = j + 1
l = l + 1
FindFixtureName = FindFixtureName.Offset(m, 0)
FindItemNumber = FindItemNumber.Offset(m, 0)
FindUPC = FindUPC.Offset(m, 0)
FindItemDesc = FindItemDesc.Offset(m, 0)
m = m + 1
Loop
TitleVar = S1.Cells(K, 4)
h = h + 1
l = 1
ShipTo = S2.Cells(h, 2)
StrSearch = UCase(S2.Cells(h, 6))
Match = ShipTo & ItemNumber
StoreNumber = S2.Cells(h, 4)
FindFixtureName = vbaNullString
Set FindFixtureName = S1.Range("D:D").Find(What:=StrSearch,
After:=S1.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Do While FindFixtureName Is Nothing
If FindFixtureName Is Nothing Then
h = h + 1
StrSearch = UCase(S2.Cells(h, 6))
Set FindFixtureName = S1.Range("D:D").Find(What:=StrSearch,
After:=S1.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
End If
Loop
Set FindItemNumber = S1.Range("D:D").Find(What:=StrSearch,
After:=S1.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0,
2)
Set FindUPC = S1.Range("D:D").Find(What:=StrSearch, After:=S1.Cells(1, 4),
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:=False).Offset(0, 3)
Set FindItemDesc = S1.Range("D:D").Find(What:=StrSearch, After:=S1.Cells(1,
4), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:=False).Offset(0, 4)
m = 1
Loop
lastRow = Sheets("Test").Range("A" & Rows.Count).End(xlUp).Row
With ActiveWorkbook.Worksheets("DIV")
lR = Sheets("Div").Range("A" & .Rows.Count).End(xlUp).Row
Sheets("Test").Range("J2: J" & lastRow).Formula =
"=IfError(VLOOKUP(C2,Div!$A$2:$G$" & lR & ",2,0),"""")"
End With
With ActiveWorkbook.Worksheets("Test")
RR = Sheets("Import").Range("A" & .Rows.Count).End(xlUp).Row
Sheets("Test").Range("K2:K" & lastRow).Formula =
"=IfError(VLOOKUP(B2,Import!$B$2:$J$" & RR & ",8,0),"""")"
Sheets("Test").Range("L1") = "0 Total"
Sheets("Test").Range("L2:L" & lastRow).Formula = "=IF(K2="""",""YES"","""")"
Sheets("Test").Range("M1") = "1 Total"
Sheets("Test").Range("M2:M" & lastRow).Formula = "=IF(K2=1,""YES"","""")"
Sheets("Test").Range("N1") = "2 Total"
Sheets("Test").Range("N2:N" & lastRow).Formula = "=IF(K2=2,""YES"","""")"
Sheets("Test").Range("O1") = "3+ Total"
Sheets("Test").Range("O2:O" & lastRow).Formula = "=IF(K2>=3,""YES"","""")"
Sheets("Test").Range("P1") = "Dup Store Match"
Sheets("Test").Range("P2:P" & lastRow).Formula = "=D2&"" ""&H2"
Sheets("Test").Range("Q1") = "Dup Store Count"
Sheets("Test").Range("Q2:Q" & lastRow).Formula = "=IF(P3=P2,""DUP"","""")"
End With
'****** End of Find
Sheets("Test").Cells.EntireColumn.AutoFit
Sheets("Test").Activate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub
をクリアしているあなたは（あなたの検索を繰り返している）を複数回不必要に - 一度*に*それを行います見つかった行への参照を取得し、必要な項目をその行から取り出します。 –
しかし、なぜ私は変数を設定すると、それはシートからそれを消去するのですか？ –
正確な変数はどれですか？ –