Running One For loop inside another Excel VBA - vba

I'm trying to run two for loops, one inside another. The inner loop should run all the way through every time the outer loop runs. I have attached my code but it's not working at the moment. There is also code to write the results to an external csv file, something which I have no idea how to do so if anyone can see any obvious mistakes then that would be much appreciated. Thank you in advance.
Public Sub Practice1()
Dim UpLim1 As Double, UpLim2 As Double, LowLim1 As Double, LowLim2 As Double
Dim outcome As String, FilePath As String, MtchUIDs As String
Dim i As Long, j As Long
Dim SRCUID As String, SNKUID As String
MtchUIDs = ""
FilePath = Application.DefaultFilePath & "\ffpstage1.csv"
Open FilePath For Output As #2
For i = 2 To 91
For j = 2 To 90
UpLim1 = Range("d" & i).Value
LowLim1 = Range("c" & j).Value
UpLim2 = Range("j" & i).Value
LowLim2 = Range("i" & j).Value
SRCUID = Range("a" & i).Value
SNKUID = Range("g" & j).Value
If UpLim2 >= LowLim1 And LowLim1 >= LowLim2 Then
MtchUIDs = SRCUID & SNKUID
ElseIf UpLim1 > LowLim2 And LowLim2 >= LowLim1 Then
MtchUIDs = SRCUID & SNKUID
Write #2, MtchUIDs
MtchUIDs = ""
Else
Next j
End If
Next i
End Sub

You need an End If within the For j loop, try this for the loops:
For i = 2 To 91
For j = 2 To 90
UpLim1 = Range("d" & i).Value
LowLim1 = Range("c" & j).Value
UpLim2 = Range("j" & i).Value
LowLim2 = Range("i" & j).Value
SRCUID = Range("a" & i).Value
SNKUID = Range("g" & j).Value
If UpLim2 >= LowLim1 And LowLim1 >= LowLim2 Then
MtchUIDs = SRCUID & SNKUID
ElseIf UpLim1 > LowLim2 And LowLim2 >= LowLim1 Then
MtchUIDs = SRCUID & SNKUID
Write #2, MtchUIDs
MtchUIDs = ""
End if
Next j
Next i

Related

How can I create a non sequential sequence like 1.1/1.2/2.1/2.2 and so on with vba?

I am working on a project that requires that I use a non sequential sequence that restarts everyday. Like this:
13/11/2017
1.1
1.2
2.1
2.2
3.1
And then starts over from 1.1 on the next day.
I'm not really sure what to do in this case. Use an array? Set an Excel column with those values? Use an event?
Can someone help me?
Here's the code so far.
Private Sub CommandButton4_Click() 'Guardar Banho Grelhas
Dim LastRow As Long, CR As Long, CRG As Long, CRP As Long, CRE As Long, ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, rgr As Long, rgp As Double, rge As Long, Ar As Variant, n As String, x As Long, d As Long, PRG As Long
Set ws = Sheets("Banho Grelhas")
Set ws2 = Sheets("STOCK Grelhas")
Set ws3 = Sheets("STOCK Pyr")
Set ws4 = Sheets("STOCK Et")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 'Banho Grelhas
CR = ws.Range("A" & Rows.Count).End(xlUp).Row
PRG = ws2.Range("A" & Rows.Count).End(xlUp).Row - 1 'Previous Row STOCK Grelhas
CRP = ws3.Range("A" & Rows.Count).End(xlUp).Row - 1 'Current Row STOCK Pyr
CRE = ws4.Range("A" & Rows.Count).End(xlUp).Row - 1 'Current Row STOCK Et
CRG = PRG + 1 'Current Row Grelhas
rgr = TextBox6.Value 'Grelhas a remover
rgp = 17.5 * 0.8 'Pyrolidona a remover
rge = 17.5 * 0.2 'Ethylenodiamina a remover
n = "001"
x = Replace(Date, "/", " ")
d = x & n
Ar = Sheets("Banho Grelhas").Range("K1:K120").Value
ws.Range("A" & LastRow).Value = d
ws.Range("B" & LastRow).Value = TextBox26.Text 'ID Carbonação
ws.Range("C" & LastRow).Value = ws2.Range("A" & CRG) 'ID Grelhas
ws.Range("D" & LastRow).Value = TextBox6.Text 'Quantidade Grelhas / Banho
ws.Range("E" & LastRow).Value = ws3.Range("A" & CRP) 'ID Pyr
ws.Range("F" & LastRow).Value = ws4.Range("A" & CRE) 'ID ET
ws.Range("G" & LastRow).Value = "1,1"
ws.Range("H" & LastRow).Value = TextBox5.Text 'TETRA
ws.Range("I" & LastRow).Value = Format(Now(), "dd/mm/yyyy hh:mm") 'Data / Hora introdução
ws.Range("J" & LastRow).Value = Date
'Nº Banho
If InStr(ws.Range("G" & CR).Value, ",1") > 0 Then
ws.Range("G" & LastRow).Value = ws.Range("G" & CR).Value + 0.1
Else
ws.Range("G" & LastRow).Value = ws.Range("G" & CR).Value + 0.9
End If
'ID Banho
If ws.Range("J" & LastRow).Value = ws.Range("J" & CR).Value Then
ws.Range("A" & LastRow).Value = ws.Range("A" & CR).Value + 1
Else
ws.Range("A" & LastRow).Value = d
End If
Do While rgr > 0
If ws2.Range("H" & CRG).Value < rgr Then
rgr = rgr - ws2.Range("H" & CRG).Value
ws2.Range("H" & CRG).Value = 0
NRG = CRG + 1
Else
ws2.Range("H" & CRG).Value = ws2.Range("H" & CRG).Value - rgr
rgr = 0
End If
Loop
Do While rgp > 0
If ws3.Range("H" & CRP).Value < rgp Then
rgp = rgp - ws3.Range("H" & CRP).Value
ws3.Range("H" & CRP).Value = 0
CRP = CRP + 1
Else
ws3.Range("H" & CRP).Value = ws3.Range("H" & CRP).Value - rgp
rgp = 0
End If
Loop
Do While rge > 0
If ws4.Range("H" & CRE).Value < rge Then
rge = rge - ws4.Range("H" & CRE).Value
ws4.Range("H" & CRE).Value = 0
CRE = CRE + 1
Else
ws4.Range("H" & CRE).Value = ws4.Range("H" & CRE).Value - rge
rge = 0
End If
Loop
TextBox4.Value = Null
TextBox5.Value = Null
'TextBox6.Value = Null
TextBox26.Value = Null
TextBox27.Value = Null
End Sub
I don't know the contents of all your variables, but based on your code I am assuming this will work as intended:
'ws.Range("G" & LastRow).Value = "1,1"
'Nº Banho
If Format(ws.Range("I" & CR).Value, "dd/mm/yyyy") = Format(Now(), "dd/mm/yyyy") Then
If InStr(ws.Range("G" & CR).Value, ",1") > 0 Then
ws.Range("G" & LastRow).Value = ws.Range("G" & CR).Value + 0.1
Else
ws.Range("G" & LastRow).Value = ws.Range("G" & CR).Value + 0.9
End If
Else
ws.Range("G" & LastRow).Value = "1,1"
End If
It looks like you're using CR as the previous line, based on how you appear to be checking whether the previous sequence-value ends in ",1" or not.
The same logic can be extended to finding out whether this is a new day or not (and conversely, whether to reset the sequence). The logic I added is primarily this line:
If Format(ws.Range("I" & CR).Value, "dd/mm/yyyy") = Format(Now(), "dd/mm/yyyy") Then
Which is to say, if the datestamp in the previous line is the same as today's datestamp it proceeds with the code that increments the value. In reverse (the outtermost Else), this means that if the datestamps do not match - meaning the line we're adding has a datestamp that isn't the same as the datestamp in the previous line - we've reached a new day and the sequence has to be reset.
You'll also see that I commented out the line that initially sets the value of col G, as it looks like this line will at some point in time override a legitimate value.

Comparing values in two columns using VBA

I am working on this code that compares column A ( code source) and column B( code roc) and for each code source in column A it has his code regate in column C and address in column D so if A=B copy them back in E and F with their code regate in column G and their address in column H .
this the code I am using it blocks until I shut down excel and it doesn't give me the exact results if anyone can help me thank you
here is a picture of the result that i need from A and B , C and D
Sub copy_lignes()
Dim DerLigA, DerLigB As Long, i, j As Long
DerLigA = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
DerLigB = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To DerLigA
For j = 2 To DerLigB
If Sheets("sheet3").Range("A" & i) = Sheets("sheet3").Range("B" & j) Then
Sheets("sheet3").Range("A" & i).Copy Destination:=Sheets("sheet3").Range("E" & i)
Sheets("sheet3").Range("B" & i).Copy Destination:=Sheets("sheet3").Range("F" & i)
Sheets("sheet3").Range("C" & i).Copy Destination:=Sheets("sheet3").Range("G" & i)
Sheets("sheet3").Range("D" & i).Copy Destination:=Sheets("sheet3").Range("H" & i)
End If
Next j
Next i
End Sub
Try the code below, maybe this is what you meant in your post:
Sub copy_lignes()
Dim DerLigA, DerLigB As Long, i, j As Long
Dim PasteRow As Long
' optimize speed performance
Application.ScreenUpdating = False
With Sheets("Sheet3")
DerLigA = .Cells(.Rows.Count, "A").End(xlUp).Row
DerLigB = .Cells(.Rows.Count, "B").End(xlUp).Row
PasteRow = 2
For i = 2 To DerLigA
For j = 2 To DerLigB
If .Range("A" & i) = .Range("B" & j) Then
.Range("A" & i).Copy Destination:=.Range("E" & PasteRow)
.Range("B" & j & ":D" & j).Copy Destination:=.Range("F" & PasteRow)
PasteRow = PasteRow + 1
End If
Next j
Next i
End With
' restore settings
Application.ScreenUpdating = True
End Sub
It might be that you just need to tab in a few lines, so it should look like this:
Sub copy_lignes()
Dim DerLigA As Long
Dim DerLigB As Long
Dim i As Integer
Dim j As Integer
i = 2
j = 2
DerLigA = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
DerLigB = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).Row
For i To DerLigA
For j To DerLigB
If Sheets("sheet3").Range("A" & i) = Sheets("sheet3").Range("B" & j) Then
Sheets("sheet3").Range("A" & i).Copy Destination:=Sheets("sheet3").Range("E" & i)
Sheets("sheet3").Range("B" & i).Copy Destination:=Sheets("sheet3").Range("F" & i)
Sheets("sheet3").Range("C" & i).Copy Destination:=Sheets("sheet3").Range("G" & i)
Sheets("sheet3").Range("D" & i).Copy Destination:=Sheets("sheet3").Range("H" & i)
End If
Next j
Next i
End Sub

VBA in Excel returning Type mismatch

I'm trying to create a Macro that will modify contents in columns S, W and AH based on the content in AB
e.g. if AB1 = No, then S1=C-MEM, AH = N/A and W is cleared.
For some reason, I get a 'Type mismatch' error on the first line of my if statement and can't figure out why or how to fix it - even after reading other posts about similar issue.
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
**-> If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
Next i
End Sub
Thanks
You are trying to test if an error is = No.
Test for the error and skip the logic in that loop:
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AB" & i).Value) Then
If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
End If
Next i
End Sub

Delete empty rows using VBA - MS Excel

I am looking to see if there is a more efficient way to achieve the result below, so it can be extended if needed.
I'm using this to clean up large spreadsheets that have the rows C-Z blank. I imagine there should be a way to clean it up so that it doesn't have to double in size if I need to clean up a spreadsheet with data from C to AZ.
It's been a while since I used VBA, I found the code below online. (counting ROW B as the spreadsheet in question had an empty ROW A)
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
If Range("C" & r).Value = "" And Range("D" & r).Value = "" And Range("E" & r).Value = "" And Range("F" & r).Value = "" And Range("G" & r).Value = "" And Range("H" & r).Value = "" And Range("I" & r).Value = "" And Range("J" & r).Value = "" And Range("K" & r).Value = "" And Range("L" & r).Value = "" And Range("M" & r).Value = "" And Range("N" & r).Value = "" And Range("O" & r).Value = "" And Range("P" & r).Value = "" And Range("Q" & r).Value = "" And Range("R" & r).Value = "" And Range("S" & r).Value = "" And Range("T" & r).Value = "" And Range("U" & r).Value = "" And Range("V" & r).Value = "" And Range("W" & r).Value = "" And Range("X" & r).Value = "" And Range("Y" & r).Value = "" And Range("Z" & r).Value = "" Then Rows(r).Delete
Next r
End Sub
Thanks!
Just add an inner loop to go through the columns you care about. This will actually run much faster, as VBA doesn't short-circuit the If statement (all of the conditionals are evaluated). But with the loop, you can exit early if you find a value anywhere:
Sub delem()
Dim last As Long
Dim current As Long
Dim col As Long
Dim retain As Boolean
last = Cells(Rows.Count, "B").End(xlUp).Row
For current = last To 1 Step -1
retain = False
For col = 3 To 26
If Cells(current, col).Value <> vbNullString Then
retain = True
Exit For
End If
Next col
If Not retain Then Rows(current).Delete
Next current
End Sub
The Excel worksheet function COUNTA is a clean way to test if a range is empty.
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
'This function Counts the number of cells that are not empty
If WorksheetFunction.CountA(Range(Cells(r, 3), Cells(r, 26)) = 0 Then
Rows(r).Delete
End If
Next r
End Sub

VBA Text Array - Scan two columns for array string match rather than one

I have some code which is designed to scan Columns F & G for occurrences of words found in an array, the array containing text found in Column J. If it finds occurrences in either Column F or Column G, it will copy and paste the terms into the corresponding columns.
Column J contains free text from a field in SAP. The field is free text so it could be "Kerry John Pub Expenses" or "CATS O/H Kerry John", or even "CATS John Kerry O/H". There is no data entry standard for this field; this is what makes this task difficult .
Column F and Column G contains first names and last names. The code makes an assumption, if it finds an entry in column F or G that matches an entry in the txt array, it will copy and paste that entry.
During testing, the code proved not sufficient to match the outcomes which I was looking for, and the solution to this problem would be to match text in Columns F and G concurrently for two matching words rather than doing them in separate intervals.
I would like some suggestions as to how this code could be re-written to achieve this result.
Example of successful code run
Here we have 4 rows of data, John Citizen is located in Row 3, therefore the blank cells in Columns F and G, Row 2 can be populated with his first and last name.
The problem
Because I have two rows that contain Kerry Citizen and John Kerry, the row is populated with Kerry Kerry as a result, where the entry should be "John" in Column F and "Kerry" in Column G
Code starts here
Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long
For I = 2 To Range("E50000").End(xlUp).row
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each T In txtArray
For J = 2 To Range("F50000").End(xlUp).row
If Range("F" & J).Value = T Then
match_txt = T
Range("F" & I).Value = match_txt
End If
Next J
Next T
For Each T In txtArray
For J = 2 To Range("G50000").End(xlUp).row
If Range("G" & J).Value = T Then
match_txt = T
Range("G" & I).Value = match_txt
End If
Next J
Next T
End If
Next I
End Sub
You can simplify your code greatly, and make it work, like this:
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
matchFound = False
For J = 2 To Range("G50000").End(xlUp).Row
If InStr(txt, Range("F" & J).Value) <> 0 _
And InStr(txt, Range("G" & J).Value) _
And Not (IsEmpty(Range("F" & J).Value)) _
And Not (IsEmpty(Range("G" & J).Value)) Then
'Both names match. Copy them.
Range("F" & I).Value = Range("F" & J).Value
Range("G" & I).Value = Range("G" & J).Value
matchFound = True
Exit For ' look no further.
End If
Next J
If Not matchFound Then MsgBox "No match found for: " & txt
End If
Tested, works for me.
The Code below runs for every first name on the list but only adds the name if both names match.
Sub arraycolumnmatch()
Dim txtArray As Variant, t As Variant
Dim I As Long, J As Long
For I = 2 To Range("G50000").End(xlUp).Row
typ = Range("F" & I).Value
If typ = "" And Not Range("J" & I).Value = Empty Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each word In txtArray
If Not word = "" Then
Set findtext = Range("F:F").Find _
(what:=(word), LookIn:=xlValues)
stoploop = False
loopcnt = 0
Do While Not findtext Is Nothing And stoploop = False And loopcnt < 21
loopcnt = loopcnt + 1
If InStr(txt, Range("F" & findtext.Row).Value) <> 0 _
And InStr(txt, Range("G" & findtext.Row).Value) Then
'Both names match. Copy them.
Range("F" & I).Value = Range("F" & findtext.Row).Value
Range("G" & I).Value = Range("G" & findtext.Row).Value
stoploop = True
Exit For ' look no further.
Else
Set findtext = Range("F" & findtext.Row & ":F" & 50000).Find _
(what:=(word), LookIn:=xlValues)
End If
Loop
End If
Next word
If Not stoploop Then MsgBox "No match found for: " & txt
End If
Next I
End Sub
Edit: Did an integration of #Jean InStr and a Find in Range which would allow for less loop time and a double match find.
I have had to stick with my original syntax, answer is below. Not the most efficient way of reaching the result, but it works
Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long
For I = 2 To Range("E50000").End(xlUp).row
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each T In txtArray
For J = 2 To Range("G50000").End(xlUp).row
If Range("G" & J).Value = T Then
match_txt = T
Range("G" & I).Value = match_txt
Exit For
End If
Next J
Next T
For Each T In txtArray
For J = 2 To Range("F50000").End(xlUp).row
If Range("F" & J).Value = T Then
match_txt = T
If Not Range("G" & I).Value = T Then
Range("F" & I).Value = match_txt
Exit For
End If
End If
Next J
Next T
End If
Next I