I have a matrix of rows and columns with data as string not integer. I have a reference cell which I want to compare with the a particular cell in each row. I have the following code.
`Worksheets("Sheet2").Activate
With Sheets("Sheet1")
str2 = Cells(1, 14).Value
For j = 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
str1 = Cells(j, 2).Value
result = StrComp(str1, str2, vbBinaryCompare)
If result = 0 Then
.Range(.Cells(j, 1), .Cells(j, 12)).Copy
ActiveSheet.Cells(2, 14).PasteSpecial Transpose:=True
End If
Next j
End With`
The problem is it is telling me that every comparison is true. Where am I going wrong?
Related
What I'm trying to do is remove any rows where a cell value in a specific column matches what is defined to remove. After that is done re-sequence the value in another column by group.
Using the example below:
I want to look at column B and remove any rows that have a value of A or C. Then I want to basically renumber after the dot (.) in column A to reset itself.
Before Macro Code Fig. 1
After value A and C are removed Fig. 2
Final list after column A is renumbered Fig. 3
I figured out how to remove the rows using this code, but stuck on what to do next:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
End Sub
This will be easier to do looping from the top down (using step 1 instead of step -1). I've tried to stay true to your original coding and made this:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
Dim startRow As Long
Dim i As Integer
startRow = 2
'Clear the rows that have "A" or "C" in column B
For RowToTest = Cells(Rows.Count, 1).End(xlUp).Row to startRow To Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
'If the left 3 characters of the cell above it are the same,_
'then increment the renumbering scheme
For RowToTest = startRow To Cells(Rows.Count, 1).End(xlUp).Row
If Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), "\")) = Left(Cells(RowToTest, 1).Offset(-1, 0).Value, InStr(1, Cells(RowToTest, 1), "\")) Then
i = i + 1
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
Else
i = 0
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
End If
Next RowToTest
End Sub
EDIT: I've updated it to compare all of the string before the backslash and compare using that.
EDIT++: It has been brought to my attention that when deleting rows it is better to work from the bottom up (step -1) to ensure every row is accounted for. I've re-implemented the original steps in the first code.
Admittedly, this isn't probably the most efficient, but it should work.
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long, i As Long
Application.ScreenUpdating = False
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" Then Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
Dim totalRows As Long
totalRows = Cells(Rows.Count, 1).End(xlUp).Row
Dim curCelTxt As String, aboveCelTxt As String
For i = totalRows To i Step -1
If i = 1 Then Exit For
curCelTxt = Left(Cells(i, 1), WorksheetFunction.Search("\", Cells(i, 1)))
aboveCelTxt = Left(Cells(i - 1, 1), WorksheetFunction.Search("\", Cells(i - 1, 1)))
If curCelTxt = aboveCelTxt Then
Cells(i, 1).Value = ""
Else
Cells(i, 1).Value = WorksheetFunction.Substitute(Cells(i, 1), Right(Cells(i, 1), Len(Cells(i, 1)) - WorksheetFunction.Search(".", Cells(i, 1))), "0")
End If
Next i
Dim rng As Range, cel As Range
Dim tempLastRow As Long
Set rng = Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In rng
If cel.Offset(1, 0).Value = "" Then
tempLastRow = cel.End(xlDown).Offset(-1, 0).Row
If tempLastRow = Rows.Count - 1 Then
tempLastRow = Cells(Rows.Count, 2).End(xlUp).Row
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
Exit For
Else
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
Mainly, I discovered that you can use AutoFill to fix the last number in the string. Meaning if you AutoFill this text, CAT\Definitions.0 down, you get the number updating as you drag/fill.
I am trying to copy a range from one sheet to another which is a result of a comparison loop. the loop first compares values in one of the cells of a row with something on the sheet and if its a match, it copies that entire range to another sheet. Here is my code:
Worksheets("Sheet1").Cells(1, 14).Value = Driver_sel
For k = 1 To Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
If ((Cells(k, 2))) = Cells(1, 14) Then
Worksheets("Sheet1").Range(Cells(k, 1), Cells(k, 12)).Copy
ActiveSheet.Cells(2, 14).PasteSpecial Transpose:=True
End If
Next k
My original program is able to find the Cells I need based on Month and Week now I need to modify the program to copy the last used cell in Row 5 and paste it until the end of the column.
Ex. If the month if November and it is the 4th week then the program knows to go there and fill in the information. I cannot figure out how to paste value from Nov wk 4 into the rest of the column. Also my range could be H5:BA5 or BC5:DB5 depending on where the month and week start.
I have added a picture that shows how my data is set up, the highlighted cells need to be filled in until the end
With ThisWorkbook.Sheets(SheetName)
Dim c2 As Integer
Dim LastCol2 As Integer
c2 = 2
LastCol2 = .Cells(4, .Columns.Count).End(xlToLeft).Column
Do Until .Cells(1, c2).Value = "Sept" And .Cells(4, c2).Value = "Wk 5"
If .Cells(1, c).Value = MonthSel And .Cells(4, c).Value = WkSel Then
.Cells(5, c2).Select
Selection.copy
ActiveCell.Offset(0, 1).Select
Selection.Paste
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("H5:BA5"), Type:=xlFillDefault
Range("H5:BA5").Select // need to change this range to reach the end of column 5
End If
Loop
End With
First off you need to STOP USING .SELECT!
Secondly, you already figured out how to find the last used column in your code. Why not use the same logic to find the last used row?
With ThisWorkbook.Sheets(SheetName)
Dim c2 As Long, LastCol2 As Long, LastRow As Long
c2 = 2
LastCol2 = .Cells(4, .Columns.Count).End(xlToLeft).Column
Do Until .Cells(1, c2).Value = "Sept" And .Cells(4, c2).Value = "Wk 5"
If .Cells(1, c).Value = MonthSel And .Cells(4, c).Value = WkSel Then
.Cells(5, c2).copy
.Cells(5, c2).Offset(0, 1).Paste
Application.CutCopyMode = False
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(5, c2).Offset(0, 1).AutoFill Destination:=Range("H5:BA" & LastRow), Type:=xlFillDefault
End If
Loop
End With
A much simpler solution (if we assume you have some sort of lookup formulas in your cells) is to grab all of column B and auto-fill all 52 weeks:
Sub TestingIt()
Dim LastRow As Long
With ThisWorkbook.Sheets(SheetName)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Range("B5:B" & LastRow).AutoFill Destination:=Range("B5:BA" & LastRow), Type:=xlFillCopy
End With
End Sub
I receive Runtime Error '13': Type Mismatch when I try to run the code. Debug highlights the 'IF' statements, but I can't figure out where the mistake is. Any help would be appreciated. Thanks
Dim i As Integer
Dim lastRow As Long
Workbooks("Template Part_II.xlsx").Worksheets(2).Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If Cells(i, 1).Value <> "#N/A" And Cells(i, 1).Value <> "00000000-000" Then
Cells(i, 1).Copy
Worksheets(1).Range("A2:A" & lastRow).PasteSpecial xlPasteValues
End If
Next I
and in fact I'm trying to do this:
I have one Sheet where I have 100 Rows of various IDs and I want to copy this IDs to another sheet without possible non ID strings in this case it can be #N/A or 00000000-0000, also I don't want those non copied cells to appear as blanks in destination range.
Wrap your accesses to the cell inside a check which ensures the cell contains no error value (e.g. a cell 'containing' a division by 0) like so
...
For i = 2 To lastRow
If Not IsError(Cells(i, 1).Value) Then
If Cells(i, 1).Value <> "#N/A" And Cells(i, 1).Value <> "00000000-000" Then
Cells(i, 1).Copy
Worksheets(1).Range("A2:A" & lastRow).PasteSpecial xlPasteValues
End If
End If
Next i
...
Note: I tried to insert the condition at the front of the existing If but it seems VBA does not use short-circuiting therefore the wrapping
Update due to comment
You may want to change your code like this
Dim i As Integer
Dim lastRow As Long
Dim targetRow As Long
Workbooks("Template Part_II.xlsx").Worksheets(2).Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
targetRow = 2
For i = 2 To lastRow
If Not IsError(Cells(i, 1).Value) Then
If Cells(i, 1).Value <> "#N/A" And Cells(i, 1).Value <> "00000000-000" Then
Cells(i, 1).Copy
Worksheets(1).Cells(targetRow, 1).PasteSpecial xlPasteValues
targetRow = targetRow + 1
End If
End If
Next i
I am new here.
I am trying to build a quick VBA program to "flatten" a Bill of Materials by heirarchy (BOM Level) and Status.
Here is some sample data:
The sample data shows a BOM with a Car as a top level assembly, Wheel and Engine as second level assemblies, and various children parts that make up those assemblies on the third and fourth level of the BOM.
I want to delete any rows that have the value "ZE", "ZM", or blank in column C.
I also want to delete any rows that have the value "ZA" and are also direct children of another "ZA" item. (Example - Delete the Rim row from the BOM because the Wheel is the Parent "ZA" item)
Here is what I have so far:
Sub deletechildren()
Dim lr As Long, i As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 1 Step -1
If i > 2 Then
k = i - 1
End If
If Cells(i, 3).Value = "ZA" And Cells(i, 1).Value = Cells(k, 1).Value Then
Cells(i, 3).EntireRow.Delete
ElseIf Cells(i, 3).Value = "ZE" Then
Cells(i, 3).EntireRow.Delete
ElseIf Cells(i, 3).Value = "ZM" Then
Cells(i, 3).EntireRow.Delete
ElseIf Cells(i, 3).Value = "" Then
Cells(i, 3).EntireRow.Delete
End If
Next i
lr = Cells(Rows.Count, 1).End(xlUp).Row
End Sub
I am getting some error on the first part of the If statement, where I want to parse out any "ZA" status children from the "ZA" parent.
Any ideas?
Sub DeleteChildren()
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If (Cells(i, 3).Value = "ZE" Or Cells(i, 3).Value = "ZM" Or Cells(i, 3).Value = "") And Cells(i, 1) <> "" Then
Rows(i).EntireRow.Delete xlShiftUp
i = i - 1
GoTo NextIteration
End If
If Cells(i, 1).Value > 1 Then
If (Cells(i, 3).Value = "ZA" And Cells(i - 1, 3).Value = "ZA") And Not Cells(i, 1).Value < Cells(i - 1, 1).Value Then ' This way is a there are multiple levels with "ZA" there can
Cells(i, 5).Value = "Delete"
End If
End If
NextIteration:
Next i
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 5).Value = "Delete" Then
Rows(i).EntireRow.Delete xlShiftUp
i = i - 1
End If
Next i
End Sub
A part of the problem is that the variable k is not being used to correctly identify parent/children relationships (if I understand your requirements correctly). In your case, you are comparing the each value with the row above it, but in a bill of materials, the parent row might be multiple rows above, and is denoted by a hierarchy value - 1.
See my revised code below. In the code, we first delete any rows that we know to delete (ZM, ZE, and Blanks). Next, we loop up the hierarchy values until we find one hierarchy value above the current row. That becomes the parent row, and from there, we test.
Let me know if you need additional help.
Sub deletechildren()
Dim lr As Long, i As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 1 Step -1
If i > 2 Then
k = i - 1
If Cells(i, 3) = "ZE" Or Cells(i, 3) = "ZM" Or Cells(i, 3) = "" Then
Rows(i).Delete
Else
k = i - 1
Do Until i <= 2 Or (Cells(i, 1) - Cells(k, 1) = 1)
k = k - 1
Loop
'Now, k represents the parent row.
If Cells(i, 3) = "ZA" And Cells(k, 3) = "ZA" Then
Rows(i).Delete
End If
End If
End If
Next i
lr = Cells(Rows.Count, 1).End(xlUp).Row
End Sub
I'd use Autofilter() and Sort() methods of Range object like follows:
Option Explicit
Sub deletechildren()
Dim i As Long
With Worksheets("BOM")
With .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
.AutoFilter Field:=3, Criteria1:=Array("ZE", "ZM", "="), Operator:=xlFilterValues
With .Offset(1).Resize(.Rows.Count - 1)
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then .SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilter
.Sort key1:=Range("C1"), order1:=xlAscending, key2:=Range("A1"), order2:=xlAscending, Header:=xlYes
i = .Rows(.Rows.Count).Row
Do Until .Cells(i, 1) = .Cells(2, 1)
i = i - 1
Loop
If i < .Rows.Count Then .Rows(i + 1).Resize(.Rows.Count - i).EntireRow.Delete
End With
End With
End Sub