I have a loop looking for text in a column (that is working) and I want to post the result in a MsgBox, but when I use the msgbox in or outside the loop I will get a msgbox for every result found or only one msgbox with one result. What I would like is to make it post every result in 1 msgbox with a line break after each result.
I know the first code is not the prettiest or best way to go around finding duplicates and I should use an array for it, but it's the only way I got it to work.
The first code finding duplicates (not relevant for the question):
Dim lastRow As Long
Dim i As Long
Dim ws As Worksheet
Dim txt As String
Set ws = Sheets("Player List")
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A201").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" &
lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
The loop with the msgbox:
For i = 2 To 201
If ws.Range("B" & i).Value = "Duplicate" Then
txt = "Duplicates found for" + " " + ws.Range("A" & i).Value + " " + "in" +
ws.Range("L" & i).Value + vbNewLine
End If
Next i
MsgBox txt
You need to persist the old value of txt.
txt = txt & "Duplicates found for" & " " & ws.Range("A" & i).Value & " " & "in" & ws.Range("L" & i).Value & vbNewLine
Related
I want to insert a vlookup into a range of cells that is defined by variables.
My problem is that the search criteria (I gave the variable the name x) in the vlookup needs to be in " ", else the vlookup doesnt work.
But if I insert those " " into the formula in any way VBA thinks I'm trying to let it take x as a value.
Does anyone know how I can solve this problem?
If there is anything else wrong with the code, please tell me too, I'm new to this.
Sub FindExchange()
n = Worksheets.Count
For k = n To 6 Step -1
Dim ws As Worksheet
Set ws = Worksheets(k)
Dim lColumn As Long
lColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For i = lColumn To 1 Step -4
Dim lrow As Long
lrow = ws.Cells(Rows.Count, i).End(xlUp).Row
x = Cells(1, i).Value
ws.Range(Cells(2, i + 2), Cells(lrow, i + 2)).FormulaLocal = "=vlookup(" & x & ";Sheet1!$B$2:$C$832;2;FALSE)"
Next i
Next k
End Sub
You can try this solution ,
"=vlookup(""" & x & """,Sheet1!$B$2:$C$832,2,FALSE)"
"=vlookup(" & """" & x & """" & ";Sheet1!$B$2:$C$832;2;FALSE)"
to get the double quotes " just add Chr(34).
change your FormulaLocal string to:
"=VLookup(" & chr(34) & x & chr(34) & ";Sheet1!$B$2:$C$832;2;FALSE)"
I have 2 worksheets in the same workbook. If a cell in SourceSheet meets certain criteria, I want to copy several non-adjacent cells in the same row to NewSheet. The problem is that it's taking over a half second to paste each and every cell, making the macro far too slow. The code below takes 8 seconds to complete a single loop. Is there a faster way I could do this?
Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long
'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row
For row = 2 To lrow
With EnrollmentChanges
course1 = Sheets("SourceSheet").Range("A" & row)
If course1 <> "" Then
course1status = Sheets("SourceSheet").Range("BS" & row)
If InStr(1, course1, "APEX") And course1status = "1" Then
NewSheetRow = NewSheetRow + 1
Sheets("NewSheet").Range("A" & NewSheetRow) = NewSheetRow
Sheets("NewSheet").Range("B" & NewSheetRow) = "W"
Sheets("NewSheet").Range("C" & NewSheetRow) = "S"
Sheets("NewSheet").Range("D" & NewSheetRow) = "MySchool"
Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("G" & NewSheetRow)
Sheets("SourceSheet").Range("W" & row).Copy Sheets("NewSheet").Range("H" & NewSheetRow)
Sheets("SourceSheet").Range("V" & row).Copy Sheets("NewSheet").Range("J" & NewSheetRow)
Sheets("SourceSheet").Range("Y" & row).Copy Sheets("NewSheet").Range("K" & NewSheetRow)
Sheets("NewSheet").Range("L" & NewSheetRow) = "OR"
Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("M" & NewSheetRow)
Sheets("SourceSheet").Range("A" & row).Copy Sheets("NewSheet").Range("P" & NewSheetRow)
End If
Else: GoTo NextRow
End If
End With
NextRow:
Next
The best way to approach this would to be avoiding copy and paste altogether (which are notoriously slow). The only time that copy/paste MAY be worth keeping is when you need to copy formatting. If you just need the values then you can do something like this:
Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long
'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row
For row = 2 To lrow
With EnrollmentChanges
course1 = Sheets("SourceSheet").Range("A" & row)
If course1 <> "" Then
course1status = Sheets("SourceSheet").Range("BS" & row)
If InStr(1, course1, "APEX") And course1status = "1" Then
NewSheetRow = NewSheetRow + 1
With Sheets("NewSheet")
.Range("A" & NewSheetRow).Value = NewSheetRow
.Range("B" & NewSheetRow).Value = "W"
.Range("C" & NewSheetRow).Value = "S"
.Range("D" & NewSheetRow).Value = "MySchool"
.Range("G" & NewSheetRow.Value = Sheets("SourceSheet").Range("B" & row).Value
.Range("H" & NewSheetRow).Value = Sheets("SourceSheet").Range("W" & row).Value
.Range("J" & NewSheetRow).Value = Sheets("SourceSheet").Range("V" & row).Value
.Range("K" & NewSheetRow).Value = Sheets("SourceSheet").Range("Y" & row).Value
.Range("L" & NewSheetRow).Value = "OR"
.Range("M" & NewSheetRow).Value = Sheets("SourceSheet").Range("B" & row).Value
.Range("P" & NewSheetRow).Value = Sheets("SourceSheet").Range("A" & row).Value
End With
End If
' No need for this since you are skipping the operation using the if block
' GoTo is messy and should be avoided where possible as well.
'Else: GoTo NextRow
End If
End With
NextRow:
Next
All I did was swap the order and assign the value directly based on the value retrieved versus storing the value retrieved as a copy, and putting it in a new location. Once you practice this a bit it will make much more sense (and it will speed up your code considerably).
As noted at the beginning, if you need formatting kept then that is a bit different.
Also, I didnt bother with optimizing or indenting any of the other elements of your code, but you will want to clean it up with proper indenting and skipping things like "GoTo".
call this sub a the top of you macro:
Sub MakeItFaster()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
End Sub
I want to create a macro that check all the cells of a column and if the first two characters of a cell is "BB" then i want the macro to extract three characters from the cell and paste it to the next column but a the corresponding row.
But my formula after the if clause is not working.
this is what i have done since:
Sub test()
Dim lmid As String
Dim srange, SelData, ExtBbFor As String
Dim lastrow As Long
Dim i, icount As Integer
lastrow = ActiveSheet.Range("B30000").End(xlUp).Row
srange = "G1:G" & lastrow
SelData = "A1:G" & lastrow
Range(srange).Formula = "=mid(E1,1,3)"
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "bb") <> 0 Then
Range("G" & i).Formula = "=mid("E & i", 4, 3)"
End If
Next i
End Sub
thanks in advance
Try with below. It will work
Range("G" & i).Value = Mid(Range("E" & i), 4, 3)
If the cell is not limited to 7 then you need as below
Range("G" & i).Value = "=Mid(E" & i & ", 3, " & Len(E & "& i & ") & ")"
It will extract from the 3rd character up to the last character in a cell.
Your syntax is wrong where you're trying to concatenate strings, I think you mean to use:
Range("G" & i).Formula = "=MID(E" & i & ",4,3)"
Based on your code I think this will do the exact same thing without having to loop or declare any variables:
Sub test()
With Range("G1:G" & Cells(Rows.Count, 2).End(xlUp).Row)
.FormulaR1C1 = "=IF(UPPER(LEFT(RC[-2],2))=""BB"",MID(RC[-2],4,3),"""")"
.Value = .Value
End With
End Sub
I have the following code, modified by #FreeMan from one of my previous questions. I want to find the text "Hours" in any row in the worksheet. Then, apply the code to the column containing that text. This code is supposed to do that, but it does not work for me for some reason. I would really appreciate your help with this. Thank you in advance.
Sub CeldasinInfo()
Dim i As Long, r As Range, coltoSearch As String
Dim Result as String
Dim ErrCount as integer
ErrCount = 0
coltoSearch = "A"
coltoSearch = Range("1:1").find(What:="Hours", LookIn:=xlValues, LookAt:=xlWhole).Column
Result = "No Value in:" & vbcrlf
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
If Len(r.Value) = 0 Then
r.Interior.ColorIndex = 3 ' Red
r.Select
MsgBox "No Value, in " & r.Address
Result = Result & r.Address & vbcrlf
ErrCount = ErrCount + 1
if ErrCount Mod 10 = 0 then 'change to 15 or 20 or whatever works well
MsgBox Result
Result = "No Value in:" & vbcrlf
End If
Sheets("Results").Range("A" & Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = r.Address
End If
Next
If ErrCount > 0 then
MsgBox "There were " & ErrCount & " errors detected." & vbcrlf & result
else
MsgBox "No errors detected"
End If
End Sub
You need to change these two lines of code:
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
to:
For i = 1 To Cells(Rows.Count, coltoSearch).End(xlUp).Row
Set r = Cells(i, coltoSearch)
Remove line: coltoSearch = "A"
coltoSearch should be an integer.
I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.