Related
I have this VBA code which ends right after the big for loop, before "msgbox "h". The msgbox is to check if it continues. The code runs through the loop but nothing more. Can someone please help me understand why?
Sub countPT()
'Select file
Application.ScreenUpdating = False
Dim i As Integer, lastRow As Integer, tellerPoE(13) As Integer,
telleruPoE(13) As Integer, SwitchInd As Integer
Dim wb As Workbook, wb2 As Workbook
Dim krrom As String, Comment As String
For i = 1 To 13
tellerPoE(i) = 0
telleruPoE(i) = 0
Next i
Set wb = ActiveWorkbook
openFile = Application.GetOpenFilename("Excel-files,*.xls*", 1, _
"Select a file to open", , False)
Application.ScreenUpdating = False
If Len(openFile) = 0 Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
End
End If
Workbooks.Open openFile
Set wb2 = ActiveWorkbook
'Read through and count -> put to array on index
lastRow = wb2.Worksheets("Rådata").Range("F" & Rows.Count).End(xlUp).Row
For i = 114 To lastRow
wb2.Activate
If CStr(wb2.Worksheets("Rådata").Cells(i, "G")) = "528" Then
krrom = CStr(wb2.Worksheets("Rådata").Cells(i, "F"))
SwitchInd = SwitchCode(krrom)
'If SwitchInd = 0 Then
'GoTo ContinueLoop
'End If
Comment = LCase(CStr(wb2.Worksheets("Rådata").Cells(i, "M")))
If (InStr(Comment, "poe") Or InStr(Comment, "kamera") Or
InStr(Comment, "cam")) Then
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
End If
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
Else
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
'ContinueLoop
End If
Next i
'Check up to existing
'Update values
'Give message on change
MsgBox "h"
For j = 1 To 13
If tellerPoE(j) > CInt(Cells(5 + j, "E")) * 2 Or telleruPoE(j) >
CInt(Cells(5 + j, "G")) Then
Cells(6 + j, "K") = "Punkter økt"
End If
Cells(5 + j, "E") = tellerPoE(j)
Cells(5 + j, "G") = telleruPoE(j)
Next j
'Empty and close
Application.CutCopyMode = False
Set wb = ActiveWorkbook
wb2.Close
Application.ScreenUpdating = True
End Sub
Some of the code are commented out as to try to fix the problem or make it easier to find blocks
After the MsgBox, delete the loop and write the following:
MsgBox "h"
For j = 1 To 13
Cells(6 + j, "K") = "Punkter økt"
Next j
check whether it produces what you need. If it does, then it works and your condition is wrong.
I am writing a VBA code on excel using loops to go through 10000+ lines.
Here is an example of the table
And here is the code I wrote :
Sub Find_Matches()
Dim wb As Workbook
Dim xrow As Long
Set wb = ActiveWorkbook
wb.Worksheets("Data").Activate
tCnt = Sheets("Data").UsedRange.Rows.Count
Dim e, f, a, j, h As Range
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
For xrow = 2 To tCnt Step 1
Set e = Range("E" & xrow)
Set f = e.Offset(0, 1)
Set a = e.Offset(0, -4)
Set j = e.Offset(0, 5)
Set h = e.Offset(0, 3)
For Each Cell In Range("E2:E" & tCnt)
If Cell.Value = e.Value Then
If Cell.Offset(0, 1).Value = f.Value Then
If Cell.Offset(0, -4).Value = a.Value Then
If Cell.Offset(0, 5).Value = j.Value Then
If Cell.Offset(0, 3).Value = h.Value Then
If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
Cell.EntireRow.Interior.Color = vbYellow
e.EntireRow.Interior.Color = vbYellow
End If
End If
End If
End If
End If
End If
Next
Next
End Sub
As you can imagine, this is taking a lot of time to go through 10000+ lines and I would like to find a faster solution. There must be a method I don't think to avoid the over looping
Here are the condition :
For each line, if another line anywhere in the file has the exact same
:
Buyer ID (col. E)
`# purchased (col. F)
Product ID (col.A)
Payment (col. J)
Date purchased (col. H)
Then, if the SUM of the Amount (col. L) the those two matching line is
0, then color both rows in yellow.
Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.
Running the previous code, in my example, row 2 & 5 get highlighted :
This is using nested dictionaries and arrays to check all conditions
Timer with my test data: Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec
Option Explicit
Public Sub FindMatches()
Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12
Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object
Set ur = ThisWorkbook.Worksheets("Data").UsedRange
x = ur
Set d = CreateObject("Scripting.Dictionary")
Set found = CreateObject("Scripting.Dictionary")
Dim r As Long, rId As String, itm As Variant, dupeRows As Object
For r = ur.Row To ur.Rows.Count
rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
If Not d.Exists(rId) Then
Set dupeRows = CreateObject("Scripting.Dictionary")
dupeRows(r) = 0
Set d(rId) = dupeRows
Else
For Each itm In d(rId)
If x(r, L) + x(itm, L) = 0 Then
found(r) = 0
found(itm) = 0
End If
Next
End If
Next
Application.ScreenUpdating = False
For Each itm In found
ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub
Before
After
I suggest a different approach altogether: add a temporary column to your data that contains a concatenation of each cell in the row. This way, you have:
A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A
Then use Excel's conditional formatting on the temporary column, highlighting duplicate values. There you have your duplicated rows. Now it's only a matter of using a filter to check which ones have amounts equal to zero.
You can use the CONCATENATE function; it requires you to specify each cell separately and you can't use a range, but in your case (comparing only some of the columns) it seems like a good fit.
Maciej's answer is easy to implement (if you can add columns to your data without interrupting anything), and I would recommend it if possible.
However, for the sake of answering your question, I will contribute a VBA solution as well. I tested it on dataset that is a bit smaller than yours, but I think it will work for you. Note that you might have to tweak it a little (which row you start on, table name, etc) to fit your workbook.
Most notably, the segment commented with "Helper column" is something you most likely will have to adjust - currently, it compares every cell between A and H for the current row, which is something you may or may not want.
I've tried to include a little commentary in the code, but it's not much. The primary change is that I'm using in-memory processing of an array rather than iterating over a worksheet range (which for larger datasets should be exponentially faster).
Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime
Sub Find_Matches()
Dim wb As Workbook, ws As Worksheet
Dim xrow As Long, tCnt As Long
Dim e As Range, f As Range, a As Range, j As Range, h As Range
Dim sheetArr() As Variant, arr() As Variant
Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
Dim arrSize As Long, i As Long, k As Long
Dim c As Variant
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Data")
ws.Activate
tCnt = ws.UsedRange.Rows.Count
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Read range into an array so we process in-memory
sheetArr = ws.Range("A2:H" & tCnt)
arrSize = UBound(sheetArr, 1)
' Build new arr with "helper column"
ReDim arr(1 To arrSize, 1 To 9)
For i = 1 To arrSize
For k = 1 To 8
arr(i, k) = sheetArr(i, k)
arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
Next k
Next i
' Iterate over array & build collection to indicate yellow lines
For i = LBound(arr, 1) To UBound(arr, 1)
If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
For Each c In colorResults
If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
Next c
Next i
' Enact row colors
For Each dictItem In colorTheseYellow
'Debug.Print "dict: "; dictItem
If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
Next dictItem
End Sub
Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
' Returns "0;0" if 1 or fewer matches
Dim i As Long
Dim j As Long
Dim tmp As String
ReturnLines = 0
j = 0
tmp = "0"
'Debug.Print "arg: " & s
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 9) = s Then
j = j + 1
'Debug.Print "arr: " & arr(i, 9)
'Debug.Print "ReturnLine: " & i
tmp = tmp & ";" & CStr(i)
End If
Next i
'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)
'Debug.Print "tmp: " & tmp
If j >= 2 Then
ReturnLines = tmp
Else
ReturnLines = "0;0"
End If
End Function
On my simple dataset, it yields this result (marked excellently with freehand-drawn color indicators):
Thanks everybody for your answers,
Paul Bica's solution actually worked and I am using a version of this code now.
But, just to animate the debate, I think I also found another way around my first code, inspired by Maciej's idea of concatenating the cells and using CStr to compare the values and, of course Vegard's in-memory processing by using arrays instead of going through the workbook :
Sub Find_MatchesStr()
Dim AmountArr(300) As Variant
Dim rowArr(300) As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set ws = ThisWorkbook.Sheets("Data")
ws.Activate
Range("A1").Select
rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To rCnt
If i = rCnt Then
Exit For
Else
intCnt = 0
strA = ws.Cells(i, 1).Value
strE = ws.Cells(i, 5).Value
strF = ws.Cells(i, 6).Value
strH = ws.Cells(i, 8).Value
strL = ws.Cells(i, 10).Value
For j = i To rCnt - 1
strSearchA = ws.Cells(j, 1).Value
strSearchE = ws.Cells(j, 5).Value
strSearchF = ws.Cells(j, 6).Value
strSearchH = ws.Cells(j, 8).Value
strSearchL = ws.Cells(j, 10).Value
If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then
AmountArr(k) = ws.Cells(j, 12).Value
rowArr(k) = j
intCnt = intCnt + 1
k = k + 1
Else
Exit For
End If
Next
strSum = 0
For s = 0 To UBound(AmountArr)
If AmountArr(s) <> "" Then
strSum = strSum + AmountArr(s)
Else
Exit For
End If
Next
strAppenRow = ""
For b = 0 To UBound(rowArr)
If rowArr(b) <> "" Then
strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
Else
Exit For
End If
Next
If intCnt = 1 Then
Else
If strSum = 0 Then
For rn = 0 To UBound(rowArr)
If rowArr(rn) <> "" Then
Let rRange = rowArr(rn) & ":" & rowArr(rn)
Rows(rRange).Select
Selection.Interior.Color = vbYellow
Else
Exit For
End If
Next
Else
strvar = ""
strvar = Split(strAppenRow, ",")
For ik = 1 To UBound(strvar)
If strvar(ik) <> "" Then
strVal = CDbl(strvar(ik))
For ik1 = ik To UBound(strvar)
If strvar(ik1) <> "" Then
strVal1 = CDbl(strvar(ik1))
If strVal1 + strVal = 0 Then
Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
Rows(sRange1).Select
Selection.Interior.Color = vbYellow
Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
Rows(sRange).Select
Selection.Interior.Color = vbYellow
End If
Else
Exit For
End If
ik1 = ik1 + 1
Next
Else
Exit For
End If
ik = ik + 1
Next
End If
End If
i = i + (intCnt - 1)
k = 0
Erase AmountArr
Erase rowArr
End If
Next
Range("A1").Select
End Sub
I still have some mistakes (rows not higlighted when they should be), the above code is not perfect, but I thought it'd be OK to give you an idea of where I was going before Paul Bica's solution came in.
Thanks again !
If your data is only till column L, then use below code, I found it is taking less time to run....
Sub Duplicates()
Application.ScreenUpdating = False
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("O2") = "=A2&E2&F2&J2&L2"
Range("P2") = "=COUNTIF(O:O,O2)"
Range("O2:P" & lrow).FillDown
Range("O2:O" & lrow).Copy
Range("O2:O" & lrow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
For i = 1 To lrow
If Cells(i, 16) = 2 Then
Cells(i, 16).EntireRow.Interior.Color = vbYellow
End If
Next
Application.ScreenUpdating = True
Range("O:P").Delete
Range("A1").Select
MsgBox "Done"
End Sub
I am generating a new workbook from a multiple workbooks, i can generate a summary of all the errors found, but when i try to copy the sheets with the error information i got the runtime error 9
These is the line failing
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
Other thing i havent add is that all the sheets on the multiple files have the same names, so i want to know if there is a way that the sheet when is copy i can add the file name and the sheet name
Sub getViolations()
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Filename = Dir(Path & "*.xls")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Dim wc As Worksheet
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = ActiveWorkbook.Sheets("Violations Summary").Range("B1")
ws.Cells(i, 2).Value = ActiveWorkbook.Sheets("Violations Summary").Range("C1")
Dim count As Integer
count = 15
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exits As Boolean
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (ActiveWorkbook.Sheets("Violations Summary").Cells(n, 2)) < 0 Then
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
End If
If IsEmpty(wc.Cells(n, 2)) Then
ws.Cells(i, n).Value = ["NA"]
End If
count = count + 1
Next n
Workbooks(Filename).Close
Filename = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
Put option explicit at top so spelling of variables is checked and that they are declared. The variable exists was mispelt and there were a number of other variables not declared. I have put some other comments in with the code.
Some of the logic i think can be simplified and i have given some examples. Also, ensure consistent use of named variable wc. If nothing else it should be easier to debug now. Compiles on my machine so give it a try.
This all works on the assumption that each workbook you open has the "Violations Summary" sheet and it is spelt as shown.
You have the filename already stored in the variable Filename so you can use (concatenate?) that with the sheetname variable.
Option Explicit 'Set this to ensure all variable declared and consistent spelling
'Consider using WorkSheets collection rather than Sheets unless you have chart sheets as well?
Sub getViolations()
Dim Path As String 'Declare you other variables
Dim FileName As String
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
FileName = Dir(Path & "*.xls")
Dim ws As Worksheet
Dim TxtRng As Range 'Declare this
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While FileName <> ""
Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
Dim wc As Worksheet 'Consider whether to place these declarations just before the loop, avoids risk others may think there will be reinitialization even though there isn't
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = wc.Range("B1") 'Use the wc variable
ws.Cells(i, 2).Value = wc.Range("C1")
Dim count As Integer
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exists As Boolean 'Corrected spelling
count = 15
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists Then 'Shortened by removing = True (evaluates in same way)
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) < 0 Then 'used wc variable
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
Else 'Simplified this as if is not empty then is empty so can use else
ws.Cells(i, n).Value = ["NA"] 'what is pupose of square brackets? These can be removed i think
End If
count = count + 1
Next n
Workbooks(FileName).Close
FileName = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
Dim Sheet As Worksheet ' declare
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
After you copy the ActiveWorkbook.Sheets(sheetName) to ThisWorkbook, ThisWorkbook becomes the ActiveWorkbook. ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1) should not throw an error but will probably cause ActiveWorkbook.Sheets("Violations Summary") to fail. For this reason, you should always fully qualify your references.
Some idealist programmers say that a subroutine should perform 1 simply task. Personally, I believe that if you have to scroll up, down, left or right to see what your code is doing it is time to refactor it. When refactoring I try to extract logical groups of tasks in a separate subroutine. This makes debugging and modifying the code far easier.
Refactored Code
Option Explicit
Sub getViolations()
Const Path As String = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Dim n As Long
Dim Filename As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Sheet1Setup ws
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
ProcessWorkbook Filename, ws.Rows(n)
Filename = Dir()
Loop
End Sub
Sub ProcessWorkbook(WBName As String, row As Range)
Dim nOffset As Long, n As Long
Dim sheetName As String
Dim WB As Workbook
Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
With WB.Sheets("Violations Summary")
row.Columns(1).Value = .Range("B1")
row.Columns(2).Value = .Range("C1")
nOffset = 12
For n = 3 To 14
If .Cells(n, 2) = "" Then
row.Columns(n).Value = ["NA"]
ElseIf (.Cells(n, 2)) = 0 Then
row.Columns(n).Font.ColorIndex = 4
row.Columns(n).Font.ColorIndex = 0
ElseIf (.Cells(n, 2)) = 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
'Range.Parent refers to the ranges worksheet. row.Parent refers to ThisWorkbook.Sheets(1)
If SheetExists(WB, sheetName) Then .Copy After:=row.Parent.Sheets(1)
row.Columns(n + nOffset) = .Cells(1, n).Value
row.Columns(n).Font.ColorIndex = 3
row.Columns(n).Value = .Cells(n, 2)
End If
Next
End With
WB.Close SaveChanges:=False
End Sub
Function SheetExists(WB As Workbook, sheetToFind As String) As Boolean
Dim ws As Worksheet
For Each ws In WB.Worksheets
If sheetToFind = ws.Name Then
SheetExists = True
Exit Function
End If
Next
End Function
Sub Sheet1Setup(ws As Worksheet)
With ws.Range("A1:N1")
.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
.Font.ColorIndex = 2
.Interior.ColorIndex = 5
.HorizontalAlignment = xlCenter
End With
End Sub
Note: row is the target Row of ThisWorkbook.Sheets(1). row.Columns(3) is a fancy way to write row.Cells(1, 3) which refers to the 3rd cell in the target row. Also note that Cells, Columns, and Rows are all relative to the range they belong to. e.g. Range("C1").Columns(2) refers to D1, Range("C1").Rows(2).Columns(2) refers to D2, Range("C1").Cells(2,2) also refers to D2.
I am trying to set up my user form to do a loop or look up to reference my table which is on a sheet and is a large data base.
I want my user form to look up what I type and then auto fill in the other textboxes so that I can limit the number of duplicates and make it more stream lined.
My code is as shown below is embedded into Textbox1 and is set up to run the code after change. It is still not working and I have worked for many days and weeks trying to figure this out.
Option Explicit
Dim id As String, i As String, j As Integer, flag As Boolean
Sub GetDataA()
If Not IsNumeric(UserForm1.TextBox1.Value) Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 7
UserForm1.Controls("TextBox" & j).Value = Cells(i + 1, j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 5 To 10
UserForm1.Controls("TextBox" & j).Value = ""
Next j
End If
Else
End If
End Sub
you may want to adopt this refactoring of your code
Option Explicit
Sub GetDataA()
Dim j As Integer
Dim f As Range
With UserForm1 '<--| reference your userform
If Not IsNumeric(.TextBox1.Value) Then Exit Sub '<--| exit sub if its TextBox1 value is not a "numeric" one
Set f = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Find(what:=.TextBox1.Value, LookIn:=xlValues, lookat:=xlWhole) '<--| try and find its TextBox1 value along column "A" cells from row 1 down to last not empty one
If f Is Nothing Then '<--| if not found
For j = 5 To 10
.Controls("TextBox" & j).Value = ""
Next j
Else '<--| if found
For j = 2 To 7
.Controls("TextBox" & j).Value = f.Offset(, j - 1).Value
Next j
End If
End With
End Sub
note: if this sub is actually inside UserForm1 code pane than you can change With UserForm1 to With Me
I want to run loop on the same workbook, but it also give me nothing. But If I run this VBA directly on the workbook (CGDSOUSD), it works well. So I am wondering how to run VBA after let VBA open a new file.
Dim rownumber As Integer
Dim colnumber As Integer
Dim total As Double
colnumber = 1
For colnumber = 1 To 23
If Cells(8, colnumber) = "DELTA" Then
total = 0
rownumber = 9
Do Until Cells(rownumber, colnumber) = "" And Cells(rownumber + 1, colnumber) = "" And Cells(rownumber + 5, 1) = ""
If Cells(rownumber, 1) = "" And (Cells(rownumber, 7).Value = "DSO TROPS" Or Cells(rownumber, 8).Value = "DSO TROPS" Or Cells(rownumber, 6).Value = "DSO TROPS") Then
total = total + (Cells(rownumber, colnumber).Value)
Else
End If
rownumber = rownumber + 1
Loop
Else
End If
colnumber = colnumber + 1
Next colnumber
total = Round(total, 2) 'will be imputed into E20 in risk tools
MsgBox total
Maybe Do Until is False.
To iterate through cells I always determine the lastrow and use a for loop.
See basic example below.
ps: use ActiveCell and activate one.
'place a value in cell A1 to A4 for test.
Sub test()
Dim lastrow As Long
lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Cells(i, 1) <> "" Then
Cells(i, 2).Value = "not empty"
End If
Next i
End Sub