VBA Looping through single row selections and executing concat code - vba

So, I've been scratching my head for a couple of hours now trying to figure this out. No matter where I look and what I do, I can't seem to make it work.
I have an excel document with ~20 columns and a completely variable number of rows. I want to concatenate each adjacent cell within the defined width (columns A:V)into the first cell (A1 for the first row), and then move to the next row and do the same until I get to the bottom. Snippet below:
Example before and after I'm trying to make
I have the code that does the concatenation. To make it work I have to select the cells I want to concatenate (A1:V1), and then execute the code. Even though some cells are blank, I need the code to treat them this way and leave semicolons there. The code works exactly as I need it to, so I've been trying to wrap it in some sort of Range select, offset, loop:
Dim c As Range
Dim txt As String
For Each c In Selection
txt = txt & c.Value & ";"
Next c
Selection.ClearContents
txt = Left(txt, Len(txt) - 2)
Selection(1).Value = txt
What I am struggling with is making the selection A1:V1, running the code, and then looping this down to A2:V1, A3:V3, etc. I think this can be done with a loops and an offset, but I cannot for the life of me work out how.
Any help at all would be much appreciated :)

This uses variant Arrays and will be very quick
Dim rng As Range
With Worksheets("Sheet4") 'change to your sheet
'set the range to the extents of the data
Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 22).End(xlUp))
'Load data into an array
Dim rngArr As Variant
rngArr = rng.Value
'create Out Bound array
Dim OArr() As Variant
ReDim OArr(1 To UBound(rngArr, 1), 1 To 1)
'Loop array
Dim i As Long
For i = LBound(rngArr, 1) To UBound(rngArr, 1)
'Combine Each Line in the array and load result into out bound array
OArr(i, 1) = Join(Application.Index(rngArr, i, 0), ";")
Next i
'clear and load results
rng.Clear
rng.Cells(1, 1).Resize(UBound(OArr, 1)).Value = OArr
End With

Here's a quick little script I made up to do this - the main thing to note is that I don't use selection, I used a defined range instead.
Sub test()
Dim i As Long
Dim target As Range
Dim c As Range
Dim txt As String
For i = 3 To 8
Set target = Range("A" & i & ":C" & i)
For Each c In target
txt = txt & c.Value & ";"
Next c
Cells(i + 8, "A").Value2 = Left$(txt, Len(txt) - 1)
txt = ""
Next i
End Sub

Just change the range on the below to your requirements:
Sub concat_build()
Dim buildline As String
Dim rw As Range, c As Range
With ActiveSheet
For Each rw In .Range("A2:V" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Rows
buildline = ""
For Each c In rw.Cells
If buildline <> "" Then buildline = buildline & ";"
buildline = buildline & c.Value2
Next
rw.EntireRow.ClearContents
rw.EntireRow.Cells(1, 1) = buildline
Next
End With
End Sub

Related

Substitute text Data from two different columns

I want to remove single word from multiple words separated by comma:
I Want a macro that should work for all sheets in workbook.
I have the following data in Column A in Sheet1, Sheet2, Sheet3.
The no of rows and data differ for different sheets.
Little Nicobar
Mildera
Mus
Nancowrie
Nehrugram
Pilomilo Island
and Following data in Column Q:
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Want output in Column R as follows:
Mildera,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mus,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Nancowrie,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nehrugram,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Pilomilo Island
Little Nicobar,Mildera,Mus,Nancowrie,Nehrugram
Means i want remove word in column A from Column R.
For this we can use the formula in R1
=TRIM(SUBSTITUTE(Q1,A1,""))
But its only working for R1.
I want a macro that provides the desired output and should work for all sheets. As the different data present in Sheet1, sheet2...sheetn.
Help me.
Try this
Sub test()
Dim vDB, vData, vR()
Dim s As String
Dim Ws As Worksheet
Dim i As Long, n As Long
For Each Ws In Worksheets
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
n = UBound(vDB, 1)
vData = .Range("q1").Resize(n)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
s = Replace(vData(i, 1), vDB(i, 1), "")
s = Replace(s, ",,", ",")
If Left(s, 1) = "," Then
Mid(s, 1, 1) = Space(1)
End If
If Right(s, 1) = "," Then
Mid(s, Len(s), 1) = Space(1)
End If
vR(i, 1) = Trim(s)
Next i
.Range("r1").Resize(n) = vR
End With
Next Ws
End Sub
Write this formula in R1 and drag down
=SUBSTITUTE(Q1,","&A1,"")
I feel like this is definitely possible with excel functions as VB seems like overkill. This puts your large string in col Q into an array and removes whatever the value in col A is. See my answer below and let me know if you have any issues. This is also assuming your data doesn't have headers.
Sub ReplaceThings()
Dim wbk As Workbook
Dim wksht As Worksheet
Dim RemoveMe As String, myList() As String, myText As String
Dim Cell As Range
Dim x As Long, lRow As Long, p As Long
Set wbk = Workbooks("StackOverflow.xlsm") 'Change this to your workbook name
'Loop through each worksheet in workbook
For Each wksht In wbk.Worksheets
With wksht
'Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For Each Cell In .Range("A1:A" & lRow)
RemoveMe = Cell.Value
'Fill array with data in Column Q
myList = Split(Cell.Offset(0, 16).Value, ",")
For x = LBound(myList) To UBound(myList)
'Loop through array and check if RemoveMe is in Array
If myList(x) = RemoveMe Then
'Remove value from array
For p = x To UBound(myList) - 1
myList(p) = myList(p + 1)
Next p
Exit For
End If
Next x
'Print value to column Q
For x = LBound(myList) To UBound(myList)
If x = 0 Then
myText = myText & myList(x)
Else
myText = myText & "," & myList(x)
End If
Next x
Cell.Offset(0, 17) = myText
myText = ""
Erase myList
Next Cell
End With
Next wksht
End Sub

How to combine multiple macros and excel functions into a single macro that executes on button click?

I need to combine multiple macros to a single macro that executes on button click. Kindly excuse me if I write anything wrong since I am completely new to excel macros and vb.
Following is the scenario.
Steps:
Calculate total
Extract reference
Compare total field value for matching reference and mark that as "Complete" if sum of total for matching references calculates to ).
(Explained...)
First i calculate the debit and credit amount to a new column called total, for this, initially I used the SUM function. after that I tried the same using the macro that executes on button click
(old macro)
Private Sub getTotal_Click()
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 5 To lastRow
Range("K" & i).Value = Range("F" & i).Value + Range("G" & i).Value
Next i
End Sub
This was so much time consuming (took around 2 hrs when executed on 75k records) than when using the formula (which finished in minutes). I am still not able to understand the reason for this. However modifiying to Dy.Lee's answer below, it took only seconds to calculate the total.
(modified based on Dy.Lee's answer)
Private Sub getTotal_Click()
Dim vDB As Variant, vR() As Variant
Dim i As Long, n As Long, lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("R5", "S" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
vR(i, 1) = vDB(i, 1) + vDB(i, 2)
Next i
.Range("AL5").Resize(n) = vR
End With
End Sub
Now moving on to the second macro which I used to extract a pattern from strings in a column D and E.
Function extractReference(cid_No As String, pm_source As String)
Dim regExp As Object, findMatches As Object, match As Object
Dim init_result As String: init_result = ""
Set regExp = CreateObject("vbscript.regexp")
With regExp
.Global = True
.MultiLine = False
.Pattern = "(?:^|\D)(\d{5,6})(?!\d)"
End With
Set findMatches = regExp.Execute(pm_source)
For Each match In findMatches
init_result = init_result + match.SubMatches.Item(0)
Next
If init_result <> "" Then
extractReference = cid_No & " | " & init_result
Else
extractReference = ""
End If
End Function
This macro was working fine.
Finally I used the following function after copying both the extracted reference and total to a new sheet and creating a datatable for that
=IF(ISBLANK([#Reference]), "", (IF((ROUND(SUMIFS([Total],[Reference],[#Reference]),2)=0), "complete", "")))
This also worked fine.
Now what I actually want is I need to avoid creating any new data tables or sheets and preform all this within current sheet on a single button click. Is there anyway that can be done without making the macro a time consuming process? Your help is higly appreciated!
Thanks in Advance
for the first part try:
Private Sub getTotal_Click()
Dim lastRow As Long
Dim sumRange As Range
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set sumRange = Range(Range("K5"), Range("K" & lastRow))
sumRange.FormulaR1C1 = "=RC[-5]+RC[-4]"
sumRange.Copy
sumRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
also, if you still want to loop notice that calling cell like .Cells(1, 1) is faster than Range("A1")
You need using Variant Array. It is faster.
Private Sub getTotal_Click()
Dim vDB As Variant, vR() As Variant
Dim i As Long, n As Long, lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("f5", "g" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
vR(i, 1) = vDB(i, 1) + vDB(i, 2)
Next i
.Range("k5").Resize(n) = vR
End With
End Sub

Excel crashes when comparing two columns VBA macro

I have two columns which I am comparing for identical entries, and pushing the matches to another column through Offset. When I run the macro I've built (off of some Microsoft canned code) it essentially freezes and crashes, since it is a nested for each loop based on cells that are used, I figured it would end upon reaching an empty cell, but I fear I may be in a infinite loop. Any help will be much appreciated.
Dim myRng As Range
Dim lastCell As Long
Dim lastRow As Long
lastRow = ActiveSheet.UsedRange.Rows.Count
Dim c As Range
Dim d As Range
For Each c In Worksheets("Sheet1").Range("AT2:AT" & lastRow).Cells
For Each d In Worksheets("Sheet1").Range("AU2:AU" & lastRow).Cells
If c = d Then c.Offset(0, 1) = c
Next d
Next c
Try this:
Dim lastRow, currentRow, compareRow As Long
Dim found As Boolean
lastRow = Range("AT2").End(xlDown).Row
For currentRow = 2 To lastRow
compareRow = 2
found = False
Do While compareRow <= lastRow And Not found
If Range("AT" & currentRow).Value = Range("AU" & compareRow).Value Then
found = True
Range("AV" & currentRow).Value = Range("AT" & currentRow).Value
End If
compareRow = compareRow + 1
DoEvents
Loop
Next currentRow
Rather than selecting ranges and then cycling through them, this does the same thing without needing to .Select anything. It also breaks out of the inner loop early if it finds a match.
I believe that there are multiple issues here:
Efficiency of the search method
Loss of responsiveness of Excel
You can dramatically improve the efficiency of the code if you can pull all values into arrays. This prevents the time spent by VBA in accessing the Excel Object model and back. Loss of responsiveness can be handled by using DoEvents. Try the code below. It may look longish but should be easy to understand.
'Find last row
Dim lastRow As Variant
lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
'Create dynamic arrays
Dim AT() As Variant: Dim AU() As Variant: Dim AV() As Variant
ReDim AT(2 To lastRow): ReDim AU(2 To lastRow): ReDim AV(2 To lastRow)
'Get all contents from Excel
For i = 2 To lastRow
AT(i) = Worksheets("Sheet1").Cells(i, 46)
AU(i) = Worksheets("Sheet1").Cells(i, 47)
Next i
'Do the comparison
For c = 2 To lastRow
For d = 2 To lastRow
If AT(c) = AU(d) Then AV(c) = AT(c)
Next d
'Allow a brief breather to Excel once in a while (don't hang)
If (c / 100) = Int(c / 100) Then DoEvents
Next c
'Place final contents to Excel
For i = 2 To lastRow
Worksheets("Sheet1").Cells(i, 48) = AV(i)
Next i
Try this for your loop:
Dim StartRange As Range, j As Long
Dim CompareRange As Range, i As Range
With Worksheets("Sheet1")
Set StartRange = .Range("AT1", .Range("AT:AT").Find("*", , , , xlByRows, xlPrevious))
Set CompareRange = .Range("AU1", .Range("AU:AU").Find("*", , , , xlByRows, xlPrevious))
For Each i In StartRange
i.Offset(, -8).Value = .Evaluate("IF(COUNTIF(" & CompareRange.Address(0, 0) & "," & i.Address(0, 0) & ")>0," & i.Value & ","""")")
Next i
End With
Dim CompareRange As Variant, To_Be_Compared As Variant, j As Variant, k As Variant
Range("AT2").Select
Selection.End(xlDown).Select
Set To_Be_Compared = Range("AT2:" & Selection.Address)
Range("AU2").Select
Selection.End(xlDown).Select
Set CompareRange = Range("AU2:" & Selection.Address)
To_Be_Compared.Select
For Each j In Selection
DoEvents
For Each k In CompareRange
If j = k Then j.Offset(0, 2) = j
Next k
Next j
I finally got it to work, after taking the suggestions and implementing them into my code, I was able to see where the mistake actually was, I was referencing the wrong column earlier in the code and through this, created no duplicate entries to match, so after fixing this, the matches now appear, I ended up offsetting them, and changing the value to "yes" to reflect the duplication in my chart.
Thank you all for the help.

Reading Manipulating and Writing Data in VBA

If I have a column of values, how do I read the values into a variable in VBA, perform some operation on it and then write it to the next column? Seems mind numbingly simple but I haven't been able to find a simple guide.
for example:
Column A = 1, 4, 5, 7
without writing formulas into column B
Dim A, B
A = column a
B = log(A)
write the values of B to the next column.
Thanks!
If you want to loop through a whole sheet you can do it like this.
Dim lRow as long
Dim strA as string
Dim strB as string
Dim ws As Excel.Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
lRow = 1
Do While lRow <= ws.UsedRange.Rows.count
'Read the data from columnA
strA = ws.Range("A" & lRow).Value
'do something with the value you got from A
strB = strA & "some other text"
strB = log(strA)
'Write it to C
ws.Range("C" & lRow).Value = strB
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
Or if you just want a certain predefined row it would be more hard coded like this.
'Read the data from columnA
strA = ws.Range("A6").Value
'do something with the value you got from A
strB = strA & "some other text"
strB = log(strA)
'Write it to C
ws.Range("C6").Value = strB
Try this macro:
Sub test()
Dim cel As Range, rng As Range
Dim logCel As Double
Dim lastRow As Integer
lastRow = Cells(1048576, 1).End(xlUp).Row
Set rng = Range(Cells(1, 1), Cells(lastRow, 1)) 'Create a range to search
For Each cel In rng
If Not IsEmpty(cel) Then 'If the cell has a value in it
logCel = Log(cel) 'add the LOG of the value to a variable
cel.Offset(0, 1).Value = logCel 'In the cell to the right of the cell, put the log
End If
Next cel
End Sub
To learn about setting cell values and such, I highly recommend using the macro recorder, then looking through the macro when you're done. Start the recorder, then enter a value into a cell, then in the one next, enter a log of that one, and you'll get some idea of how VBA works.
Rather than looping through cell by cell you would write directly to the worksheet using a LOG formula (no need for an array as the manipulation can be used directly with inserting a formula):
Sub LikeThis()
Dim rng1 As Range
`work on A1:A20 and write to B1:B20
Set rng1 = [a1:a20]
rng1.Offset(0, 1).FormulaR1C1 = "=IF(RC[-1]>0,LOG(RC[-1]),""not valid"")"
End Sub

Update Worksheet by comparing it to another Worksheet

I have an excel Worksheet ("Sheet1") that I need to compare with another Worksheet ("Sheet2").
Both Worksheets are formatted exactly alike. (i.e. columns are the same, with the same headers)
When comparing Sheet1 with Sheet2, I need to check for updates to existing records.
Also check for new records in Sheet2 that don't exist in Sheet1, and append them to the bottom of Sheet1.
Some Columns in Sheet 2 are completely blank and don't need to be checked.
Column 2 would be the "Key"
Also keep in mind that there are over 7000 rows in each worksheet.
Update #1:
Using the dictionary object, I came up with this. However, it doesn't seem to find any new entries. Am I doing something wrong?
Sub createDictionary()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim maxRows1, maxRows2 As Long
Dim i, j As Integer
Dim SheetOne, SheetTwo As Worksheet
maxRows1 = Sheets("Sheet1").UsedRange.Rows.Count
Set SheetOne = Sheet1
Set SheetTwo = Sheet2
For i = 2 To maxRows1
If Not dict.exists(SheetOne.Cells(i, 2).Value + " " + SheetOne.Cells(i, 11).Value) Then
dict.Add CStr(SheetOne.Cells(i, 2).Value) + " " + SheetOne.Cells(i, 11).Value, i
End If
Next i
maxRows2 = Sheets("Sheet2").UsedRange.Rows.Count
For j = 2 To maxRows2
If Not dict.exists(Sheet2.Cells(j, 2).Value) Then
SheetTwo.Range("A" & j & ":" & "Z" & j).Copy
SheetOne.Range("A" & maxRows1 + 1).Insert Shift:=xlDown
SheetOne.Range("A" & maxRows1 + 1).Interior.Color = RGB(200, 200, 200)
End If
Next j
Set dict = Nothing
End Sub
Try using a dictionary object, it doesn't have a limit on how much it can hold (only limit is your computer)
I would loop through sheet1, add each key to the dictionary and map it to a collection that stores the rowIndex and the hash made from the rows values. Then loop through the keys in sheet2 and see if each key exists in the dictionary; if it doesn't, copy the row to sheet1. If the key does exist, then hash the row in sheet2 and compare to the dictionary item, if they are different you know you need to update the row.
To copy a row and paste it really quickly, you can simply access a ow's value2 property. This will be useful when appending + when updating
Here's some test code to get you started.
Sub loopCellInColumn()
Dim cell As Object
Dim sheet As Worksheet
Dim rng As Range
Set sheet = ActiveSheet
Set rng = sheet.UsedRange.Columns("A").Cells
For Each cell In rng
Row = cell.Row
cell.Value = "Hello World" & Row
Next cell
End Sub
and for using a dictionary:
Sub createDictionary()
Dim dict As Object
Dim value As Collection
Set dict = CreateObject("Scripting.Dictionary")
Key = "hello"
Set value = New Collection
value.Add 100, "row"
value.Add "A2D121E4", "hash"
dict.Add Key, value
MsgBox "key exists: " & dict.exists(Key) & vbNewLine & "value: " & dict(Key).Item("hash")
End Sub
copy + paste using value2:
Sub test()
ActiveSheet.Rows(1).Value2 = ActiveSheet.Rows(2).Value2
End Sub
ex of getting a row as string:
Sub getRowAsString()
Dim cell As Object
Dim sheet As Worksheet
Dim str As String
Dim arr() As Variant
Dim arr2() As Variant
Dim printCol As Integer
Set sheet = ActiveSheet
printCol = sheet.UsedRange.Columns.Count + 1
For Each cell In sheet.UsedRange.Rows
arr = cell.Value2
ReDim arr2(LBound(arr, 2) To UBound(arr, 2))
For i = LBound(arr, 2) To UBound(arr, 2)
arr2(i) = arr(1, i)
Next i
str = Join(arr2, ", ")
ActiveSheet.Cells(cell.Row, printCol).Value = str
Next cell
End Sub
Here is a post of getting a hash value from string, includes vba code:
All of the steps I listed have numerous posts supporting them, so resources won't be an issue
I repeat this often across this forum :), however, such operations are much more easy to handle using SQL.
I would either use Microsof Query (Excel Data->Get External Data->From Other sources->From Microsoft Query) OR I suggest using my SQL Add-In to Excel: http://blog.tkacprow.pl/?page_id=130
Seems like you need to need to use the JOIN operator to find the changes between Sheets 1 and 2. Then using a UNION operator you join a second SELECT with a LEFT OUTER JOIN to add the additional new rows.