i have the following code and am stuck as of now.
Instead of this line, i actually want to delete the row. How to do that?
cData(rw, 5) = "Matching DES found"
For rw = 1 To UBound(cData, 1)
'For Each e In cRng
For rw2 = 1 To UBound(cData, 1)
If Left(cData(rw, 1), 4) <> "DES_" Then
a = cData(rw, 3)
If Left(cData(rw2, 1), 4) = ("DES_") And Right(cData(rw2, 1), Len(a)) = a Then
cData(rw, 5) = "Matching DES found"
'cData(rw, 1) = Empty
Exit For
'GoTo nextI
Exit For
Else
cData(rw, 5) = "unique"
'GoTo nextE
End If
Else
'GoTo nextI
Exit For
End If
'nextE:
Next
'nextI:
Next
Here a solution with the use of a ListBox in memory:
(deleting backwards)
Set ListBoxData = CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}") 'Listbox
ListBoxData.List = cData
For rw = ListBoxData.ListCount - 1 To 0 Step -1
'For Each e In cRng
For rw2 = ListBoxData.ListCount - 1 To 0 Step -1
If Left(ListBoxData.List(rw, 0), 4) <> "DES_" Then
a = ListBoxData.List(rw, 2)
If Left(ListBoxData.List(rw2, 0), 4) = "DES_" And Right(ListBoxData.List(rw2, 0), Len(a)) = a Then
ListBoxData.List(rw, 4) = "Matching DES found"
ListBoxData.RemoveItem rw 'remove your row
'ListBoxData(rw, 1) = Empty
Exit For
'GoTo nextI
'Exit For
Else
ListBoxData.List(rw, 4) = "unique"
'GoTo nextE
End If
Else
'GoTo nextI
Exit For
End If
'nextE:
Next
'nextI:
Next
newcData = ListBoxData.List 'cleaned Listboxdata to a new Array, but lbound = 0 so act accordingly
Related
Sub FormatAndIncompleteOrders()
Dim a, Q&, i&, b(1 To 2), R, j%
Application.ScreenUpdating = False
Rem -----------------------------------\
a = Range("'Original Data'!A3").CurrentRegion: Q = UBound(a)
ReDim R(1 To Q, 1 To 4): b(1) = R: b(2) = R
ReDim R(1 To 2) As Long
Rem -----------------------------------\
For i = 2 To Q
Select Case True
Case a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> ""
R(1) = 1 + R(1): b(1) = fillArray(b(1), R(1), a, i)
Case a(i, 2) <> ""
R(2) = 1 + R(2): b(2) = fillArray(b(2), R(2), a, i)
End Select
Next
Rem -----------------------------------\
With Sheets("New Orders")
.Select
.Range("A3").CurrentRegion.Offset(1).Delete xlShiftUp
.Range("A4").Resize(R(1), 4) = b(1)
End With
Rem -----------------------------------\
With Sheets("Incomplete Orders")
.Range("A1").CurrentRegion.Offset(1).Delete xlShiftUp
.Range("A2").Resize(R(2), 4) = b(2)
End With
End Sub
*I am trying to use the code below to format and clean data it keeps giving me an error message "Sub or function not defined"
I have 2 columns of data: Item numbers and the image name for them (A and C):
Updated sample data:
If an image filename matches the item number, I want to match them in column B (empty) otherwise fall back to a default (if available).
Example: Iterate through column A & C, if image matches the item number, match, otherwise fall back to default. In my case, default would end with either -5.jpg, -4.jpg, 4-ROOM.jpg or 5-ROOM.jpg.
So the desired result (in column B above) would be everything except for LRL0547A-24.jpg would be matched with LRL0547-4-ROOM.jpg (because it's one of the fallbacks).
My code I've tried is here (I need another pair of eyeballs, mine are hurting):
Public Sub test()
Dim ws As Worksheet, arr(), r As Long, c As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
arr = ws.Range("A2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
On Error Resume Next
For r = LBound(arr, 1) To UBound(arr, 1)
For c = LBound(arr, 1) To UBound(arr, 1)
Select Case True
Case Right$(arr(c, 3), 9) = "4-ROOM.jpg" And Left$(arr(c, 3), Len(arr(c, 3)) - 9) = arr(r, 1)
arr(r, 2) = arr(c, 3)
Exit For
Case Right$(arr(c, 3), 6) = "5-ROOM.jpg" And Left$(arr(c, 3), Len(arr(c, 3)) - 6) = arr(r, 1)
arr(r, 2) = arr(c, 3)
Exit For
Case Right$(arr(c, 3), 6) = "-5.jpg" And Left$(arr(c, 3), Len(arr(c, 3)) - 6) = arr(r, 1)
arr(r, 2) = arr(c, 3)
Exit For
End Select
Next
Next
On Error GoTo 0
ws.Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Your inner loop needs to keep checking for an exact match, even if you already found a fallback.
Untested:
Public Sub test()
Dim ws As Worksheet, arrSku, arrImg, r As Long, c As Long, itm, img, p As Long
Dim rngSku As Range, rngImg As Range
Dim exactMatch, fallBack, pm
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rngSku = ws.Range("A2:B" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
Set rngImg = ws.Range("C2:D" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
arrSku = rngSku.Value 'each array has two "columns"
arrImg = rngImg.Value
For r = 1 To UBound(arrImg, 1) 'loop the images and remove any extension
img = Trim(arrImg(r, 1))
p = InStrRev(img, ".")
If p > 0 Then img = Left(img, p - 1)
arrImg(r, 2) = img 'caching the name with no extension back in the array
Next r
For r = 1 To UBound(arrSku, 1)
itm = Trim(arrSku(r, 1))
exactMatch = "" 'clear any previous matches
fallBack = ""
For c = 1 To UBound(arrImg, 1)
img = arrImg(c, 2) 'checking against no-extension value
If img = itm Then
exactMatch = arrImg(c, 1) 'with extension
Exit For 'no need to check further
Else
For Each pm In Array("4-ROOM", "5-ROOM", "-5")
If itm & pm = img Then
fallBack = arrImg(c, 1)
Exit For 'stop checking for fallbacks, but keep checking for exact match...
End If
Next pm
End If
Next
'did we make any kind of match?
If Len(exactMatch) > 0 Then
arrSku(r, 2) = exactMatch
ElseIf Len(fallBack) > 0 Then
arrSku(r, 2) = fallBack
Else
arrSku(r, 2) = ""
End If
Next
rngSku.Value = arrSku 'put back data into A:B
End Sub
If this doesn't do what you want then please post some sample data in text format so I can test.
I have researched several codes but it's either for blanks only or zeroes only, and I need a code for both blanks and zeroes.
I have 3 columns to note if this should be deleted or not
I need to delete the rows with complete details(ID, and Address)(the Name is the basis for the details), since I need the rows with incomplete details(ID or Address as zeroes or blanks) to retain.
ID Name Address
1 A 123 ABC
2 B 0
C 345 CDE
D
5 E 567 EFG
0 F 678 FGH
7 G 789 GHI
0 H 0
My first try was this code, it works for the conditions, but if I have succeeding blanks, it skips the next row, since that row goes up
lrow = 1000
For x = 2 To lrow
If Cells(x,2)<>"" Then
If Cells(x,1) <> "" Or Cells(x,1) <> "0" Or Cells(x,3) <> "" Or Cells(x,3) <> "0" Then
Cells(x,11).EntireRow.Delete
End If
End If
Next x
So I tried this code, where I start from bottom to up.
lrow = 1000
For x = lrow To 2 Step -1
If Cells(x,2)<>"" Then
If Cells(x,1) <> "" Or Cells(x,1) <> "0" Or Cells(x,3) <> "" Or Cells(x,3) <> "0" Then
Cells(x,11).EntireRow.Delete
End If
End If
Next x
But that code ignores the conditions except the first one, then also deletes the other row s with incomplete details.
I'm kind of stuck with this, since I also have to create another one where I do the reverse, keep the complete details, and delete the incomplete ones.
Replace the for loop with a do while loop. If the row is deleted, decrement the total number of rows, otherwise increment the row counter.
lastRow = 1000
row = 2
Do While row <= lastRow
If Cells(row,1)<>"" Then
If Cells(row,1) <> "" Or Cells(row,1) <> "0" Or Cells(row,3) <> "" Or Cells(row,3) <> "0" Then
Rows(row).Delete
lastRow = lastRow - 1
else
row = row + 1
End If
End If
Loop
Delete Rows with Conditions
Loop Backward
Sub testSimple()
Const lrow As Long = 1000
Dim x As Long
For x = lrow To 2 Step -1
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 Then
If Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
Rows(x).Delete
End If
End If
Next x
End Sub
EDIT:
The star of the show is the If statement which should ideally (most efficiently) actually be:
If Len(Cells(x, 1)) > 0 Then
If Cells(x, 1) <> 0 Then
If Len(Cells(x, 3)) > 0
If Cells(x, 3) <> 0 Then
Rows(x).Delete
End If
End If
End If
End If
All four conditions have to be true. If one isn't, the others are not evaluated.
On the other hand you can write it like this
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 _
And Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
Rows(x).Delete
End If
... the difference being that in the latter (less efficient) all four conditions are evaluated, even if the first is already false.
For the opposite you could use the same conditions and do the following (note the Else):
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 _
And Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
' Do nothing
Else
Rows(x).Delete
End If
Let's rewrite the opposite using Or:
If Len(Cells(x, 1)) = 0 Or Cells(x, 1) = 0 _
Or Len(Cells(x, 3)) = 0 Or Cells(x, 3) = 0 Then
Rows(x).Delete
End If
So similar to the 'opposite idea' you could write the initial statement like this (note the Else):
If Len(Cells(x, 1)) = 0 Or Cells(x, 1) = 0 _
Or Len(Cells(x, 3)) = 0 Or Cells(x, 3) = 0 Then
' Do nothing
Else
Rows(x).Delete
End If
The Finale (for the opposite)
Using the Select Case statement you can write the opposite like this:
Sub testSimple()
Const lrow As Long = 1000
Dim x As Long
For x = lrow To 2 Step -1
Select Case True
Case Len(Cells(x, 1)) = 0, Cells(x, 1) = 0, _
Len(Cells(x, 3)) = 0, Cells(x, 3) = 0
Rows(x).Delete
End Select
Next x
End Sub
... where the commas 'mean Or', so if any of the expressions are true, the rows will be deleted.
OLD (Continuation):
Delete in One Go Using the CombinedRange Function
Sub test()
Const lrow As Long = 1000
Dim drg As Range
Dim x As Long
For x = 2 To lrow
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 Then
If Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
Set drg = CombinedRange(drg, Rows(x))
End If
End If
Next x
If Not drg Is Nothing Then
drg.Delete
End If
End Sub
Delete in One Go Using the CombinedRange Function Improved
Sub testImp()
Const Cols As String = "A:C"
Const fRow As Long = 2
Dim rg As Range
With Columns(Cols).Rows(fRow)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If rg Is Nothing Then Exit Sub
Set rg = .Resize(rg.Row - .Row + 1)
End With
Dim drg As Range
Dim rrg As Range
For Each rrg In rg.Rows
If Len(rrg.Cells(1)) > 0 And rrg.Cells(1) <> 0 Then
If Len(rrg.Cells(3)) > 0 And rrg.Cells(3) <> 0 Then
Set drg = CombinedRange(drg, rrg.EntireRow)
End If
End If
Next rrg
If Not drg Is Nothing Then
drg.Delete
End If
End Sub
The CombinedRange Function
Function CombinedRange( _
ByVal BuildRange As Range, _
ByVal AddRange As Range) _
As Range
If BuildRange Is Nothing Then
Set CombinedRange = AddRange
Else
Set CombinedRange = Union(BuildRange, AddRange)
End If
End Function
I have the following list, I want to sort the dates and display the recent ones and stock them in ranges 21 and 22 like this:
I have successfully written this code that helped to do the sorting and display the recent dates and stock them on range 21, now I am stack and I dont know how to do to display the end date associated to each recent date.
Loop Until Not ech
' conversion of numbers into text for dico and listbox)
' and the false dates (written in text) to real dates
On Error GoTo PasDate
For i = 2 To UBound(t)
t(i, 1) = CStr(t(i, 1))
If TypeName(t(i, 2)) = "String" Then t(i, 2) = 1 * DateSerial(Right(t(i, 2), 4), Mid(t(i, 2), 4, 2), Left(t(i, 2), 2))
Next i
On Error Resume Next
'Fill dico
Set dico = CreateObject("scripting.dictionary")
dico.CompareMode = TextCompare
For i = 2 To UBound(t)
If t(i, 1) <> "" Then
If Not dico.Exists(t(i, 1)) Then
dico.Add t(i, 1), t(i, 2)
Else
If t(i, 2) > dico(t(i, 1)) Then dico(t(i, 1)) = t(i, 2)
End If
End If
Next i
'Transfert dico to the table r for the list
ReDim r(1 To dico.Count, 1 To 2): i = 0
For Each x In dico.Keys: i = i + 1: r(i, 1) = x: r(i, 2) = dico(x): Next
'fill ranges 20 and 21
.Range("b20:b21").Resize(, Columns.Count - 1).Clear
.Range("b20").Resize(1, UBound(r)).HorizontalAlignment = xlCenter
.Range("b21").Resize(1, UBound(r)).NumberFormat = "dd/mm/yyyy"
.Range("b20").Resize(2, UBound(r)).Borders.LineStyle = xlContinuous
.Range("b20:b21").Resize(2, UBound(r)) = Application.Transpose(r)
End With
'poplate the listbox
For i = 1 To UBound(r): r(i, 1) = Format(r(i, 2), "dd/mm/yyyy"): Next
'For i = 1 To UBound(r): r(i, 1) = Format(r(i, 1), "000"): r(i, 2) = Format(r(i, 2), "dd/mm/yyyy"): Next
With ListBox1
.ColumnCount = 2
.ColumnHeads = False
.ColumnWidths = .Width * 0.7 '& ";" & .Width * (1 - 0.6 + 0.1)
.List = r
End With
Exit Sub
'
PasDate:
Exit Sub
End
End Sub
I am having an issue with the "Subscript out of Range" error message. I got some help writing a code that loops a long list of stocks. The code basically makes all of the vectors even so i can use it in a panel data setting.
The loop stops after 4 stocks and gives me a "Subscript out of Range" error.
I can run the code over the first 95 "i" i.e. if i transform the first part:
For i = 4 To 95
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Code:
**Sub Outer_Loop()
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row**
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Next i
End Sub
Sub Clean_Stock_2(ByVal r As Long)
Dim Stock(31, 5)
Dim Quarter(31)
Dim Bo As Boolean
Charge = 0
'Frame
For i = 0 To 31
Stock(i, 0) = Cells(r, 1)
Stock(i, 1) = Cells(r, 2)
Stock(i, 2) = Cells(r, 3)
Stock(i, 5) = "Q" & Format(DateAdd("q", i, #1/1/2011#), "q-YYYY")
Quarter(i) = Stock(i, 5)
Next i
'Data
Do While Cells(r, 1) = Stock(0, 0)
Qu = "Q" & Format(Cells(r, 4), "q-YYYY")
rr = Application.Match(Qu, Quarter, 0)
If Not IsError(rr) Then
Stock(rr, 3) = Cells(r, 4)
Stock(rr, 4) = Cells(r, 5)
If Not Bo Then Charge = Stock(rr, 4): Bo = True
End If
r = r + 1
Loop
'fill
For i = 0 To 31
If Stock(i, 4) = 0 Then
Stock(i, 4) = Charge
Else
Charge = Stock(i, 4)
End If
Next i
'Output
lr = Cells(Rows.Count, "I").End(xlUp).Row + 1
lr = IIf(lr < 3, 3, lr)
Cells(lr, "I").Resize(32, 6) = Stock
End Sub