As you can see in this excel example, column A has mixed data.
The bold M numbers are the "keys" and the blue text that is indented and blue is linked to it. I'm trying to figure out how to separate the blue text from the bold M numbers but keep them linked as I am trying to insert this data into a SQL database.
So for example, this is the output I am trying to get to, so I can insert it into my database table.
I've tried doing text to column, but I am having an issue linking them to the appropriate bold number. I'm thinking this is in call for excel-vba, but I don't know where to begin. Any help would be greatly appreciated.
You do not need VBA. If the BOLD values will always start with "M" then do the following:
B1: =A1
B2: =IF(LEFT(A2,1)="M",A2,B1)
C1: =IF(LEFT(A1,1)="M","",A1)
The result will have columns B and C populated with the data as you need.
If by any chance you need VBA, you may go for something like this:
Option Explicit
Public Sub TestMe()
Dim rngCell As Range
Dim colBold As New Collection
Dim colNormal As New Collection
Dim colTimes As New Collection
Dim varMy As Variant
Dim lngCounter As Long
Dim lngSum As Long
Dim lngCur As Long
Dim lngBoldCounter As Long
Dim lngMax As Long
Dim rngMyRange As Range
Set rngMyRange = Range("A1:A20")
For Each rngCell In rngMyRange
If rngCell.Font.Bold Then
colTimes.Add lngSum
colBold.Add rngCell
lngCounter = 0
Else
lngSum = lngSum + 1
lngCounter = lngCounter + 1
colNormal.Add rngCell
End If
Next rngCell
lngCounter = 1
lngSum = 0
lngBoldCounter = 1
lngMax = colBold.Count + 1
rngMyRange.Offset(, 4).Clear
rngMyRange.Offset(, 5).Clear
For Each varMy In colNormal
Cells(lngCounter, 5) = varMy
Cells(lngCounter, 6) = colBold(lngBoldCounter)
If lngCounter < colNormal.Count Then
If colTimes(lngBoldCounter + 1) <= lngCounter Then
lngBoldCounter = lngBoldCounter + 1
If lngBoldCounter = lngMax Then
lngBoldCounter = lngBoldCounter - 1
Debug.Print varMy.Address
End If
End If
End If
lngCounter = lngCounter + 1
Next varMy
End Sub
The code is not optimal as I have made it on the go, but it takes the bold into account and produces the columns 5 and 6, concerning them.
Related
I am trying to make a button that will take a list of names and match them up with each other over multiple weeks without matching the same people up twice. With the code I have written I get an error that says "Compile Error: Expected Array"
Below is the code that I have so far. Any help would be appreciated
Sub nameMatcher()
Dim column As Integer
Dim cellsDown As Integer
Dim randomNumber As Integer
Dim names As String
Dim i As Byte
Dim arI As Byte
Dim myRange As Range
Dim myCell As Range
Dim numNames As Integer
Worksheets("Sheet1").Activate
cellsDown = 3
column = Application.InputBox(Prompt:="What meeting number is this for?", Type:=1)
numNames = Application.CountA(Range("A:A")) - 1
i = 1
Do While i <= numNames
randomNum:
randomNumber = Application.RandBetween(2, numNames + 1)
For arI = LBound(names) To UBound(names)
If names(arI) = Cells(randomNumber, 1).Value Then
GoTo randomNum
End If
Next arI
names(i) = Cells(randomNumber, 1).Value
i = i + 1
Loop
Worksheet
For arI = LBound(names) To UBound(names)
Cells(cellsDown, column) = names(arI)
cellsDown = cellsDown + 1
Next arI
Application.ScreenUpdating = True
End Sub
Like #Warcupine suggested - your main problem is your not declaring your array as a variant or an array. Both will work, but I think it's simplest to declare as a variant and then assign your column of values to create the array
Change
Dim names As String
To
Dim names As Variant
Then after the line (are you subtracting 1 to ignore header??)
numNames = Application.CountA(Range("A:A")) - 1
Add this line to fill in your array (assuming top row is ignored header)
names = Range("A2:A" & numNames+1)
And then you'll have to change all your array references to use the second dimension as 1
So names(arI) becomes names(arI,1)
and names(i) becomes names(i,1)
I'd like to multiply the cells of column P with the cells in column M and replace the content of column P with the respective product. Afterwards I want to do the exact same thing with columns Q and N.
I've been trying to look this issue up and the closest solution was: VBA multiply two named ranges
Unfortunately, after running through the first column and calculating it, Excel gives me a runtime error 13 - type mismatch.
My code:
Sub rechnen_mod()
Dim aud_y As Range
Dim soc_r As Range
Dim mp_y As Range
Dim mp_r As Range
Set aud_y = Sheets("MRP score template").[P11:P1000]
Set soc_r = Sheets("MRP score template").[Q11:Q1000]
Set mp_y = Sheets("MRP score template").[M11:M1000]
Set mp_r = Sheets("MRP score template").[N11:N1000]
For i = 1 To Range("P").End(xlDown).Row
aud_y(i, 1) = aud_y(i, 1) * mp_y(i, 1)
Next i
For j = 1 To Range("Q").End(xlDown).Row
soc_r(j, 1) = soc_r(j, 1) * mp_r(j, 1)
Next j
End Sub
Any help would be very appreciated.
EDIT: After reading <stackoverflow.com/a/22056347/11231520> I changed the code to:
Public Sub array1()
Dim x As Long
Dim arr
Dim arr_e
Dim arrf
Dim arrf_e
Dim results
Dim r As Range
arr = Sheets("MRP score template").[P11:P473]
arrf = Sheets("MRP score template").[M11:M473]
ReDim results(1 To UBound(arr) * UBound(arrf))
For Each arr_e In arr
For Each arrf_e In arrf
x = x + 1
results(x) = arr_e * arrf_e
Next arrf_e
Next arr_e
Set r = Sheets("calc").Range("A1:A" & UBound(results))
r = Application.Transpose(results)
End Sub
Excel gives me a runtime error 13 - type mismatch with the explanation that arrf_e = error 2402. After a quick research this should mean that the array contains #NA - but it doesn't.
After clicking on debugging, the marked line is
results(x) = arr_e * arrf_e
Try to use below code instead. I also added comments to explain each step :)
Option Explicit
Public Sub rechnen_mod()
Dim mp_y() As Variant
Dim mp_r() As Variant
Dim aud_y() As Variant
Dim soc_r() As Variant
Dim arrResult_P() As Variant
Dim arrResult_Q() As Variant
Dim iLastRow As Integer
Dim iSizeArrays As Integer
Dim iIndexSearch As Integer
With ThisWorkbook.Worksheets("MRP score template")
' Find last row of table, replace it with fixed value if you prefer
iLastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
' Store data in arrays
mp_y = .Range("M11", "M" & iLastRow).Value
mp_r = .Range("N11", "N" & iLastRow).Value
aud_y = .Range("P11", "P" & iLastRow).Value
soc_r = .Range("Q11", "Q" & iLastRow).Value
' Calculate size of arrays
iSizeArrays = UBound(mp_y) - LBound(mp_y) + 1
' ReDim result arrays according to iSizeArrays
ReDim arrResult_P(1 To iSizeArrays)
ReDim arrResult_Q(1 To iSizeArrays)
' Calculate result values
For iIndexSearch = 1 To iSizeArrays
arrResult_P(iIndexSearch) = mp_y(iIndexSearch, 1) * aud_y(iIndexSearch, 1)
arrResult_Q(iIndexSearch) = mp_r(iIndexSearch, 1) * soc_r(iIndexSearch, 1)
Next iIndexSearch
' Write results in the worksheet
.Range("P11", "P" & iLastRow) = Application.WorksheetFunction.Transpose(arrResult_P)
.Range("Q11", "Q" & iLastRow) = Application.WorksheetFunction.Transpose(arrResult_Q)
End With
End Sub
I tested it with random values on 250 rows and it worked fine.
Recently I was wondering about the possibility of speeding up the program by switching a part of the code below:
Dim cell as Variant
Dim myValues() as Double
ReDim myValues(myRange.Count - 1)
Dim i as Integer: i = 0
For Each cell in myRange.Cells
myValue(i) = cell.Value
i = i + 1
Next cell
into a loop where I could refer to the value of each cell directly, instead of instantiating a cell object, assigning it a cell value from a given range, and then extracting the cell value.
In my mind, the pseudocode would look something like this:
Dim cellValue as Double
Dim myValues() as Double
ReDim myValues(myRange.Count - 1)
Dim i as Integer: i = 0
For each cellValue in myRange.Cells.Values
myValues(i) = cellValue
i = i + 1
Next cellValue
If my overall concept is wrong from the start, or if you can't get the cells values from Range faster, then there was no question.
Due to the fact that this is my first post, I could have written something incorrectly / in wrong posting convention. Let me know and I'll fix it.
Cheers
As #SJR notes, this is a common way to access data from a range without going cell-by-cell
Dim arr, i as long, rng As Range
Set rng = Activesheet.Range("A1:B20")
arr = rng.Value 'arr is now a 2D array (1 To 20, 1 To 2)
'Note: base is 1 and not the more-typical 0
For i = 1 to ubound(arr,1)
Debug.Print arr(i, 1), arr(i, 2)
Next i
arr(3, 2) = 999
rng.value = arr 'put the data back to the range
If the reason is for getting rid of the 2D array a function like this can be the solution:
Function VectorFromRange(rng As Range) As Variant
Dim arrIn As Variant
arr = rng.value 'Dumping the data from range
Dim i As Long
Dim item As Variant
ReDim arrOut(1 To rng.Cells.Count) As Variant
For Each item In arr
i = i + 1
arrOut(i) = item
Next item
VectorFromRange = arrOut
End Function
I want to match rows from two different sheets and highlight only in the first column of the unmatched row or better still copy the unmatched rows into a new sheet. The code should compare the rows of the two Sheets and color the new rows in the second sheet. Sheet2 (say Jan 2020) contains more rows than Sheet1 (Dec 2019) as its the recently updated sheet and they both contain rows of over 22k with both having unique ID as the first column.
My below code tries to highlight all the unmatching cells and takes longer time to finish. What I wish is for the code to just color the unmatched in column A (the vb.Red) only(since its the unique ID) while ignoring the rest of the column/cells (vb.Yellow) and or if possible copy the highlighted rows into a new sheet.
Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
For j = 1 To cnt1
If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
For c = 2 To 22
If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
Exit For
End If
If j = cnt1 Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
End If
Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub
Let's simplify the task and do it step by step.
This is how the input in the two sheets can look like:
Then, we may consider reading these and saving them to an array:
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Looping between the data in the two arrays is quite fast in vba. The writing to the third worksheet is done only once the two values from the two arrays match:
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
This is the result in the third worksheet, all matching values are in a single row:
This is how the whole code looks like:
Sub CompareTwoRanges()
Dim rangeA As Range
Dim rangeB As Range
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
End Sub
Note - there will be another performance bonus, if the results are written to an array and then written from the array to the worksheet. Thus the writing would happen only once. This is the change, that needs to be implemented in the code, after the array declarations:
Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
resultArray(i) = myValA
i = i + 1
End If
Next
Next
ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)
when you get cell value, it spends time.
so, you can target Range transfer 2d Variant
Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))
'Transfer
olderVariant = olderRange
For currentRow = 1 to UBound(olderVariant, 1)
'Loop
'if you want change real Cell value Or interior
'add row Or Col weight
if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
End if
Next currentRow
In case anyone has the same kind of problem, I have found an easier way to do it. Providing your sheet2 is the comparison sheet:
Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long
Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary1)
.Item(Ary1(r, 1)) = Empty
Next r
For r = 1 To UBound(Ary2)
If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
Next r
End With
I have this bit of code below that is very close to what I am looking to do. How it works is you press the “List Word Issue” button in the excel spreadsheet and it scans all the text, cell by cell and row by row in column A, against a separate worksheet containing a list of words. If there is a match (between what’s in each individual cell in column 1) then it puts the word(s) that match into the adjacent row in column b.
Here (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) is a link to the article that I found the code on and a link (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls) to download the entire .xls spreadsheet.
What I am looking for is a simple change so there will not be a “match” unless the word appears at least 5 times in each cell/row in column A of the first worksheet.
Sub WordCount()
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
ElementCounter = 2 'setting a default value for the counter
Worksheets(1).Activate
For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
vrWordIssue = ""
ElementCounter = ElementCounter + 1 'increases the counter every loop
For lngLoop = LBound(vArray) To UBound(vArray)
If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
If vrWordIssue = "" Then
vrWordIssue = vArray(lngLoop) 'assigning the word
Else
If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
End If
End If
End If
Next lngLoop
Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
Next rngCell
End Sub
Quick comment about some of the code, if you're interested:
Dim lngLoop, lngLastRow As Long
lngLoop is actually Variant, not a long. Unfortunately, you cannot declare data types like this as you can in, say, C++.
You need to do this instead:
Dim lngLoop As Long, lngLastRow As Long
Also, WordIssue is never used. It is supposed to be vrWordIssue.
In fact, I would almost never use Variant for anything in VBA. I don't believe this author of that website knows a good amount of VBA. (at least, not when they wrote that)
That said, the first thing I would fix are the variables:
From:
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
To:
Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range
And add Option Explicit to the top of the module. This will help with debugging.
...And you don't almost never have to use Activate for anything...
....you know what? I would just use a different approach entirely. I don't like this code to be honest.
I know it's not encouraged to provide a full-blown solution, but I don't like not-so-good code being spread around like that (from the website that Douglas linked, not necessarily that Douglas wrote this).
Here's what I would do. This checks against issue words with case-sensitivity, by the way.
Option Explicit
Public Type Issues
Issue As String
Count As Long
End Type
Const countTolerance As Long = 5
Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
Dim sh As Excel.Worksheet
Dim iLastRow As Long, i As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Worksheets("Word")
theIssues = getIssuesList()
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
' loop through worksheet Word
For i = 3 To iLastRow
Call evaluateIssues(sh.Cells(i, 1), theIssues)
Call clearIssuesCount(theIssues)
Next i
End Sub
Private Function getIssuesList() As Issues()
' returns a list of the issues as an array
Dim sh As Excel.Worksheet
Dim i As Long, iLastRow As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Sheets("Issue")
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim theIssues(iLastRow - 2)
For i = 2 To iLastRow
theIssues(i - 2).Issue = sh.Cells(i, 1).Value
Next i
getIssuesList = theIssues
End Function
Private Sub clearIssuesCount(ByRef theIssues() As Issues)
Dim i As Long
For i = 0 To UBound(theIssues)
theIssues(i).Count = 0
Next i
End Sub
Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
Dim vArray As Variant
Dim i As Long, k As Long
Dim sIssues As String
vArray = Split(r.Value, " ")
' loop through words in cell, checking for issue words
For i = 0 To UBound(vArray)
For k = 0 To UBound(theIssues)
If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
'increase the count of issue word
theIssues(k).Count = theIssues(k).Count + 1
End If
Next k
Next i
' loop through issue words and see if it meets tolerance
' if it does, add to the Word Issue cell to the right
For k = 0 To UBound(theIssues)
If (theIssues(k).Count >= countTolerance) Then
If (sIssues = vbNullString) Then
sIssues = theIssues(k).Issue
Else
sIssues = sIssues & ", " & theIssues(k).Issue
End If
End If
Next k
r.Offset(0, 1).Value = sIssues
End Sub