1
Ich habe 2 Arbeitsblätter:Variablen entfernen Daten aus Zellen - Loop Help; VBA
a) Eine Fixture Liste, mit allen Komponenten des Geräts.
b) Eine Geschäftsliste, die Geschäfte hat, die das Fixture haben.
c) Was ich brauche - Fixture Liste mit Fixture Components, die auch die Läden, die die Fixtures haben.
Ich muss ein 3. Arbeitsblatt erstellen, das eine Kombination der beiden Arbeitsblätter enthält. Momentan habe ich die Funktion a find, die nach dem Namen des Fixtures sucht; Das erstellt dann basierend auf den benötigten Informationen Variablen und platziert die Variablen auf dem 3. Blatt.
Aber wenn ich die ursprüngliche Variable Informationen festlegen, verschwindet der Name der Variablen, so dass die nächste Schleife, der Fixture-Namen nicht in der Suche gefangen werden.
Die Speicherliste ist RIESIG, und das führt dazu, dass das Makro sehr langsam ausgeführt wird; So würde jede Hilfe, die es effizienter macht, geschätzt werden.
Ich habe meinen Code angehängt, weil ich das nicht gut erkläre.
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
Sie Ihre Find() mehrere Male unnötig zu wiederholen - es tun * einmal * zu Holen Sie sich einen Verweis auf die gefundene Zeile und ziehen Sie dann die benötigten Elemente aus dieser Zeile. –
Aber sehen Sie warum, wenn ich eine Variable setze, löscht sie es vom Blatt? –
Welche exakte Variable? –