I have a description in Column A which contains some error code like ESFB-1 , ESFB-11 etc... with list of error codes in sheet2 a total of about 36 error codes
I have the below code written & works but the only problem is it is treating both ESFB-1 & ESFB-11 as same the list has about 35 error codes with similar nomenclature below is the code
enter code here
Sub sear()
Dim rng As Range
Dim str As String
Dim str1 As String
Dim val1 As Long
Dim val2 As Long
Dim col As Integer
Dim col2 As Integer
Dim row2 As Integer
Dim row As Integer
Dim var As Integer
Dim lastRow As Long
Dim lastrow1 As Long
Dim pos As Integer
lastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).row
lastrow1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row
var = 0
col = 1
row = 2
row2 = 2
pos = 0
Do While var <> 1
Do While row <= lastrow1
Do While pos = 0
str = Sheets("Sheet1").Cells(row, 1).Value
str1 = Sheets("Sheet2").Cells(row2, 1).Value
pos = InStrRev(str, str1, vbTextCompare)
row2 = row2 + 1
If row2 = lastRow Then Exit Do
Loop
If pos <> 0 Then
Cells(row, 7).Value = Sheets("Sheet2").Cells(row2 - 1, 1)
End If
Cells(row, 8).Value = pos & Sheets("Sheet1").Cells(row, 1)
pos = 0
row2 = 2
row = row + 1
Loop
var = 1
Loop
End Sub
Please suggest modifications which can help me find the exact error code from description
Instr will give you false positive like you are getting for ESFB-1 & ESFB-11 and hence you need a more robust check.
Is this what you are trying?
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lRow As Long
Dim Arws As Variant, tempAr As Variant
Dim rng As Range, aCell As Range
'~~> Set your sheets here
Set ws1 = Sheet1: Set ws2 = Sheet2
With ws2
lRow = .Range("A" & .Rows.Count).End(xlUp).row
'~~> Store the error codes in an array
Arws = .Range("A1:A" & lRow)
End With
With ws1
lRow = .Range("A" & .Rows.Count).End(xlUp).row
'~~> This is your range from 1st sheet
Set rng = .Range("A2:A" & lRow)
'~~> Loop through all cells and split it's contents
For Each aCell In rng
tempAr = Split(aCell.Value)
'~~> Loop through each split word in the array
For i = LBound(tempAr) To UBound(tempAr)
'~~> Check if exists in array
If ExistsInArray(Trim(tempAr(i)), Arws) Then
'~~> If it does then write to col B
aCell.Offset(, 1).Value = Trim(tempAr(i))
Exit For
End If
Next i
Next aCell
End With
End Sub
'~~> Function to check if a string is int he array
Function ExistsInArray(s As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
ExistsInArray = Application.Match(s, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
ExistsInArray = Application.Match(s, Application.Index(arr, , i), 0)
On Error GoTo 0
If ExistsInArray = True Then Exit For
Next
End Select
End Function
Screenshot
Related
I have this table:
Quantity Name
1 A
3 C1
3 C2
4 D
I'm trying to make this table change to:
Quantity Name
1 A
1 A
3 C1
3 C1
3 C1
3 C2
3 C2
3 C2
4 D
4 D
4 D
4 D
But the result is not as expect: Result
Pls help my solve this problem.
Thanks!
Here is my code:
Sub newrow()
Dim xRg As Range
Dim xAddress As String
Dim I, xNum, xLastRow, xFstRow, xCol, xCount As Long
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Select a range to use(single column):", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
xLastRow = xRg(1).End(xlDown).Row
xFstRow = xRg.Row
xCol = xRg.Column
xCount = xRg.Count
Set xRg = xRg(1)
For I = xLastRow To xFstRow Step -1
xNum = Cells(I, xCol)
If IsNumeric(xNum) And xNum > 0 Then
Rows(I + 1).Resize(Cells(I, xCol) - Cells(I - 1, xCol)).Insert
xCount = xCount + xNum
End If
Next
xRg.Resize(xCount, 1).Select
Application.ScreenUpdating = True
End Sub
First of all …
If you Dim xFstRow, xCol, xCount As Long then only xCount is of type Long all the others are of type Variant. You need to specify a type for every variable!
Dim xFstRow As Long, xCol As Long, xCount As Long
Don't ever use On Error Resume Next without proper error handling. This only hides error messages but the errors still occur you just cannot see them. Therefore you cannot debug/fix your code. Remove it completely or implement a complete error handling instead.
You need to copy the row before you insert, otherwise you just insert empty rows.
I suggest the following code:
Option Explicit
Public Sub AddRowsFromQantities()
Dim SelAddress As String
SelAddress = ActiveWindow.RangeSelection.Address
Dim SelRange As Range
Set SelRange = Application.InputBox("Select a range to use(single column):", "KuTools For Excel", SelAddress, , , , , 8)
Dim fRow As Long
fRow = SelRange.Row 'first row of selected rang
Dim lRow As Long
lRow = fRow + SelRange.Rows.Count - 1 'last row of selected range
'find last used row within the selected range
If Cells(Rows.Count, 1).End(xlUp).Row < lRow Then
lRow = Cells(Rows.Count, 1).End(xlUp).Row
End If
Application.ScreenUpdating = False
Dim iRow As Long
For iRow = lRow To fRow Step -1
If IsNumeric(Cells(iRow, 1)) Then
Dim Quantity As Long
Quantity = Cells(iRow, 1).Value
If Quantity > 1 Then
Rows(iRow).Copy
Rows(iRow).Resize(RowSize:=Quantity - 1).Insert
End If
End If
Next iRow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I am learning VBA,
I have data in sheet1 18 rows with 5 columns and Sheet2 3 rows with 8 columns
I would like to loop data and print in NOTEPAD like,
Rows 1 - 6 from sheet1 then Row 1 from sheet2
Rows 7 - 12 from sheet1 then Row 2 from sheet2
Row 13 - 18 from sheet1 then Row 3 from Sheet2, so on.
Here is my code,
Sub Looping()
Dim str As String
Dim MaxStrLen As String
Dim rest As Integer
Dim Lstr As Integer
Dim LMstr As Integer
Dim MStr As Integer
Dim LR As Range
Dim CNT As Integer
Dim LastRow As Long
Dim LastCol As Long
Dim LRow As Long
Dim LCol As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim i As Long
Dim j As Long
Dim Page_Break As Long
Dim k As Long
Dim PB As Long
Dim x As Long
Dim y As Long
Dim rng As Range
Set rng = Range("A1:E6")
Dim FilePath As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")
Open "C:\Users\Antony\Music\Excel Macros\Test.txt" For Output As #2
'''''FIRST FIVE LINES WILL PRINT IN THE NOTEPAD
With ws1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRow = ws2.Cells(.Rows.Count, 1).End(xlUp).Row
LCol = ws2.Cells(1, .Columns.Count).End(xlToLeft).Column
BlkSize = 6 'data consists of blocks of 6 rows
For i = 1 To LastRow
sOut = vbNullString
LengthRow = i
Do While LengthRow > BlkSize
LengthRow = LengthRow - BlkSize
Loop
'LengthRow points to row where char length is to be taken from
For j = 1 To LastCol
str = .Cells(i, j).Value
If str <> Empty Then
MStr = ws2.Cells(LengthRow, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
Else
MStr = ws2.Cells(LengthRow, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
End If
Next
Print #2, sOut
Next
End With
'''''LAST LINE WILL PRINT IN THE SAME NOTEPAD
With ws3
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
slast = vbNullString
For k = 2 To LRow
str = Join(Application.Transpose(Application.Transpose(.Cells(k, "A").Resize(1, LastCol).Value)), "##")
str = Replace(str, "=", vbNullString)
Print #2, str
Next
Endtext = "EODR"
Print #2, slast & Endtext
End With
'Loop
Close #2
End Sub
You can embed the loops:
For i = 0 to 2
For j = 1 to 6
Write Sheet1 row = i * 6 + j to file 'this line not actual code
Next j
Write Sheet2 row = i + 1 to file 'this line not actual code
Next i
i need to check if a cell in a column (X:X) is a duplicate and if a cell in another column (AB:AB) is 0, and if the conditions match highlight the respective row in a color. This is what I have but it's not working..
Dim cell1 As Variant, myrngg1 As Range, clr1 As Long
Set myrngg1 = Range("X1:X" & Cells(Rows.count, "X").End(xlUp).Row)
clr1 = 1
For Each cell1 In myrngg1
If Application.WorksheetFunction.CountIf(myrngg1, cell1) > 1 And Range("AB" & clr1).Value = 0 Then
cell1.EntireRow.Interior.Color = vbGrey
End If
clr1 = clr1 + 1
Next
this one works for me. picks up both 0 and "0"
Option Explicit
Sub test()
Dim cell1 As Variant, myrngg1 As Range
Set myrngg1 = Range("X1:X" & Cells(Rows.Count, "X").End(xlUp).Row)
For Each cell1 In myrngg1
If Application.WorksheetFunction.CountIf(myrngg1, cell1) > 1 And cell1.EntireRow.Columns("AB").Value & "" = "0" Then
cell1.EntireRow.Interior.Color = rgbGrey ' vbGrey is undefined in my version of excel
End If
Next
End Sub
Tested yours:
Dim cell1 As Variant, myrngg1 As Range, clr1 As Long
Set myrngg1 = Range("X1:X" & Cells(Rows.count, "X").End(xlUp).Row)
clr1 = 1
For Each cell1 In myrngg1
If Application.WorksheetFunction.CountIf(myrngg1, cell1) > 1 And Range("AB" & clr1).Value = 0 Then
cell1.EntireRow.Interior.Color = vbGrey
End If
clr1 = clr1 + 1
Next
Rebuilt using a for loop:
Dim i as Long, LR as Long
LR = Cells( Rows.Count, "X").End(xlUp).Row
For i = LR to 1 Step -1
If Application.CountIf(Range(Cells(1,"X"),Cells(LR,"X")), Cells(i,"X").Value) > 1 AND CellS(i, "AB").Value = 0 Then
Rows(i).EntireRow.Interior.Colo = vbGrey
End If
Next i
Both this and the one you've provided work for me; I have manually input values into col(X) and col(AB) to test... make sure you have formatted correctly the col(AB) so that it picks up zero and a number, not a string.
I have an excel file with one column with data. Something like:
21/07/2017
DEF
GHI
Field 7
SOMETHING HERE
MORE TEXT
21/07/2017
DEF
GHI
Field 7
This is repeated a few thousand times. What I am looking for is all rows between and including 21/07/2017 and Field 7 to be deleted and for the rows to be moved up.
I've tried a few things but now back to a blank canvas! Any hints?
Thanks
CODE I TRIED
I get an Overflow error
Sub deleteRows()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
RowCount = 1
Application.DisplayAlerts = False
Set sh = ActiveSheet
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "21/07/2017" Then
a = RowCount
End If
If sh.Cells(rw.Row, 1).Value = "Field 7" Then
b = RowCount
Rows(a & ":" & b).Delete
End If
RowCount = RowCount + 1
Next rw
End Sub
This will only loop as many times as the pair exists and delete each block as a whole.
The loop ends the first time that both are not found in the remaining values.
Sub myDelete()
Dim str1 As string
Dim str2 As String
Dim rng As Range
Dim ws As Worksheet
Dim i As Long
Dim j As Long
str1 = "21/07/2017"
str2 = "Field 7"
Set ws = Worksheets("Sheet18") 'change to your worksheet
Set rng = ws.Range("A:A")
Do
i = 0: j = 0
On Error Resume Next
i = Application.WorksheetFunction.Match(str1, rng, 0)
j = Application.WorksheetFunction.Match(str2, rng, 0)
On Error GoTo 0
If i > 0 And j > 0 Then
ws.Rows(i & ":" & j).Delete
End If
Loop Until i = 0 Or j = 0
End Sub
If your date is a true date then change str1 to Double:
Dim str1 As Double
and then assign it as such:
str1 = CDbl(DateSerial(2017, 7, 21))
The below is my code. I have tried many different solutions but none seem to work. Any help would be appreciated.
Sub MultiDimensiionArray1()
'array for sheet one and sheet two
Dim myArraySheet1(0 To 3, 0 To 4) As Variant
Dim myArraySheet2(0 To 5, 0 To 4) As Variant
Dim i As Long, j As Long ' dimension counter for for sheet one
Dim Dimension1 As Long, Dimension2 As Long ' dimension counter for for sheet one
'number of rows in sheet one
Dim x As Integer, NumRows As Integer
Sheet1.Activate
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
'store everything on sheet one in array
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
myArraySheet1(i, j) = Range("A2").Offset(i, j).Value
Next j
Next i
'store everything on sheet two in array
Sheet2.Activate
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
myArraySheet2(Dimension1, Dimension2) = Range("A2").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
'READ FROM ARRAY/OR DISPLAY THE RESULT
Sheet1.Activate
' Select sheet one cell G2
Range("G2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
'if sheet one row equal to sheet two row execute the below code
If myArraySheet1(i, j) = myArraySheet2(Dimension1, Dimension2) Then
ActiveCell.Value = "YES IT IS DUPE AND NOT RESOLVED"
ActiveCell.Interior.ColorIndex = 4
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = "Brand New"
ActiveCell.Interior.ColorIndex = 3
ActiveCell.Font.ColorIndex = 2
End If
Next Dimension2
Next Dimension1
Next j
Next i
Next
End Sub
I did not use array but the code below give you the expected output that you want:
Option Explicit
Sub Compare()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long, Lastrow2 As Long
Dim i As Integer, j As Integer, c As Integer
Dim FOUND As Boolean
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
FOUND = False
For j = 2 To Lastrow2
For c = 1 To 5
If ws1.Cells(i, c).Value = ws2.Cells(j, c).Value Then
FOUND = True
Else
FOUND = False
Exit For
End If
Next c
If FOUND = True Then
ws1.Cells(i, 7) = "YES IT IS DUPE AND NOT RESOLVED"
Exit For
End If
Next j
If FOUND = False Then
ws1.Cells(i, 7) = "Brand new"
End If
i = i + 1
Loop While i < Lastrow + 1
End Sub
With this you'll have two arrays containing values of cells that aren't equal so you'll be able to use the values you need to do what you want
Sub Test()
Dim DiffSh1() As Variant
Dim DiffSh2() As Variant
Call Compare_Sheets(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Sheet2"), DiffSh1, DiffSh2)
'Now you can use the values in the two arrays as you need
For x = LBound(DiffSh1, 1) To UBound(DiffSh1, 1)
For y = LBound(DiffSh1, 2) To UBound(DiffSh1, 2)
If DiffSh1(x, y) <> "" Then
MsgBox ("Cell at Row " & x & " Column " & y & " isn't equal:" & vbCrLf & _
"Value in sheet1 is: " & DiffSh1(x, y) & vbCrLf & _
"Value in sheet2 is: " & DiffSh2(x, y))
End If
Next y
Next x
End Sub
Public Sub Compare_Sheets(ByVal Sh1 As Worksheet, ByVal Sh2 As Worksheet, ByRef DiffIn1() As Variant, ByRef DiffIn2() As Variant)
Dim LastCol
Dim LastRow
LastCol = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Column
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column > LastCol Then
LastCol = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column
End If
LastRow = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Row
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row > LastRow Then
LastRow = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row
End If
ReDim DiffIn1(1 To LastRow, 1 To LastCol)
ReDim DiffIn2(1 To LastRow, 1 To LastCol)
Dim mCol As Long, mRow As Long
For mCol = 1 To LastCol
For mRow = 1 To LastRow
If Sh1.Cells(mRow, mCol) <> Sh2.Cells(mRow, mCol) Then
DiffIn1(mRow, mCol) = Sh1.Cells(mRow, mCol).Value
DiffIn2(mRow, mCol) = Sh2.Cells(mRow, mCol).Value
Else
DiffIn1(mRow, mCol) = ""
DiffIn2(mRow, mCol) = ""
End If
Next mRow
Next mCol
End Sub