This should capitalize every character but I get type mismatch error.
It works fine for other worksheets that have similar data but for no reason it gives me mismatch error. Please help
Private Sub allUpper(ByRef sh As Worksheet)
Dim arr As Variant, i As Long, j As Long
If WorksheetFunction.CountA(sh.UsedRange) > 0 Then
arr = sh.UsedRange 'one interaction with the sheet
For i = 2 To UBound(arr, 1) 'each "row"
For j = 1 To UBound(arr, 2) 'each "col"
arr(i, j) = UCase(RTrim(Replace(arr(i, j), Chr(10), vbNullString)))
Next
Next
sh.UsedRange = arr 'second interaction with the sheet
End If
End Sub
You probably have an error (#N/A, etc.) somewhere in your data.
You can add a check for that to prevent the run time error:
If Not IsError(arr(i, j)) Then
arr(i, j) = UCase(RTrim(Replace(arr(i, j), Chr(10), vbNullString)))
End If
Related
I am trying to copy values from once column to another using vba. I am using the follwoing vba script:
Private Sub Import_Click()
Worksheets("test").Range("D10:D49") = Worksheets("test2").Range("G22:G61").Value
End Sub
But this just copies the values from one column to another. My question is this, consider the example below:
I want to copy the "Num" from table 1 to table 2 by matching it with the "items". Is there a way to do it using VBA? cuz, my actual list is really long.
If you are dealing with a large number of data and want to use VBA you can use dynamic arrays.
Try this example :
I have reproduced your example assuming first table is located on columns A & B, and 2nd one E & F (boths on first line):
Sub lookup_with_arrays()
Dim wb As Workbook
Dim ws As Worksheet
Dim arr1(), arr2() As Variant
Dim lastrow_arr1, lastrow_arr2, i, j As Long
Set wb = Workbooks("Your_File.xlsm")
Set ws = wb.Worksheets("Your_Sheet")
lastrow_arr1 = Range(ws.Cells(1, 1), ws.Cells(1, 1).End(xlDown)).Rows.Count
lastrow_arr2 = Range(ws.Cells(1, 5), ws.Cells(1, 5).End(xlDown)).Rows.Count
'Set dynamic dimensions
ReDim arr1(1 To lastrow_arr1, 1 To 2)
ReDim arr2(1 To lastrow_arr2, 1 To 2)
'Indicate which data to set up in the arrays
For i = LBound(arr1) To UBound(arr1)
arr1(i, 1) = ws.Cells(i, 1)
arr1(i, 2) = ws.Cells(i, 2)
Next i
For i = LBound(arr2) To UBound(arr2)
arr2(i, 1) = ws.Cells(i, 5)
arr2(i, 2) = ws.Cells(i, 6)
Next i
'Now we can match both Items colums and complete arr2 second column
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
If arr1(i, 1) = arr2(j, 1) Then
arr2(j, 2) = arr1(i, 2)
Exit For
End If
Next j
Next i
'Then you can report arr2 in your worksheet
For i = 2 To UBound(arr2)
ws.Cells(i, 6) = arr2(i, 2)
Next i
End Sub
Another option would be to use a Vlookup function :
Function VLOOKUP(TheValueYouNeed As Variant, RangeOfSearch As Range, No_index_col As Single, Optional CloseValue As Boolean)
On Error GoTo VLookUpError
VLOOKUP = Application.VLOOKUP(TheValueYouNeed, RangeOfSearch, No_index_col, CloseValue)
If IsError(VLOOKUP) Then VLOOKUP = 0
Exit Function
VLookUpError:
VLOOKUP = 0
End Function
I am not the creator of the function but I don't remember where I have found it (thanks anyway)
And then use it nearly as if you were in excel :
Sub lookup_using_function()
Dim lastrow_arr1, lastrow_arr2, i As Long
Dim looked_item As Variant
Dim search_table As Range
Dim col_num As Single
Dim bool As Boolean
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks("Your_File.xlsm")
Set ws = wb.Worksheets("Your_Sheet")
lastrow_arr1 = Range(ws.Cells(1, 1), ws.Cells(1, 1).End(xlDown)).Rows.Count
lastrow_arr2 = Range(ws.Cells(1, 5), ws.Cells(1, 5).End(xlDown)).Rows.Count
Set search_table = ws.Range("A:B")
col_num = 2
bool = False
For i = 2 To lastrow_arr2
looked_item = ws.Cells(i, 5)
ws.Cells(i, 6) = VLOOKUP(looked_item, search_table, col_num, bool)
Next i
Then I usually insert a form, right click on it to assign a macro.
On click the macro assigned is executed.
Edit following your comment:
Cells() works with coordinates.
For example ws.Cells(5,4) stands for cell 5th row of 4th column in the worksheet called ws.
So If your table starts on line 6 and column 3:
'Indicate which data to set up in the arrays (i+5 instead of i)
For i = LBound(arr1) To UBound(arr1)
arr1(i, 1) = ws.Cells(i+5, 3)
arr1(i, 2) = ws.Cells(i+5, 4)
Next i
LBound and Ubound are useful in order to set for loop for an entire array.
To loop through rows:
For i=LBound(arr1) to UBound(arr1)
Next i
To loop through columns you provide the additional argument 2 (default is 1)
For i=LBound(arr1, 2) to UBound(arr1, 2)
Next i
If your table have various columns you may have to loop also through columns to specify which data you want:
For i=LBound(arr1) to UBound(arr1)
For j=LBound(arr1, 2) to UBound(arr1, 2)
arr1(i, j) = ws.Cells(i+5, j+2)
Next j
Next i
I am trying to remove duplicates but with case sensitivity.
For example, ABC123 is not the same as abc123, hence, do not remove it.
But ABC123 and ABC123 is the same, hence, remove them.
This is my current code:
Dim oDic As Object, vData As Variant, r As Long
Set oDic = CreateObject("Scripting.Dictionary")
With worksheets(4).Range("A7:A" & lastRow)
vData = .Value
.ClearContents
End With
With oDic
.comparemode = 0
For r = 1 To UBound(vData, 1)
If Not IsEmpty(vData(r, 1)) And Not .Exists(vData(r, 1)) Then
.Add vData(r, 1), Nothing
End If
Next r
Range("A7").Resize(.Count) = Application.Transpose(.keys)
End With
Some background:
The entire dataset has about 800k records
The script has no error, but the result is wrong. When I remove duplicate (regardless of case sensitivity, I have 400k left) but running this script, 450k (which sounds legit), but only 60k records have data, 390k shows #N/A. So I have no idea where went wrong.
Thanks in advance!
As stated in the first comment, Application.Transpose has a limitation of 65,536 array rows. Please, try the next function able to transpose without such a limitation:
Function TranspKeys(arrK) As Variant
Dim arr, i As Long
ReDim arr(1 To UBound(arrK) + 1, 1 To 1)
For i = 0 To UBound(arrK)
arr(i + 1, 1) = arrK(i)
Next i
TranspKeys = arr
End Function
After copying the functionin the same module where your existing code exists, only modify it as:
Range("A7").Resize(.Count,1) = TranspKeys(.keys)
Unique Values Case-Sensitive
Transpose has its limitations and is best avoided (what's a few more lines).
Option Explicit
Sub DictWith()
With Worksheets(4)
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastRow < 7 Then Exit Sub
With .Range("A7:A" & LastRow)
Dim Data As Variant
If .Rows.Count = 1 Then
ReDim Data(1 To 1, 1 To 1)
Data(1, 1).Value = .Value
Else
Data = .Value
End If
With CreateObject("Scripting.Dictionary")
.CompareMode = vbBinaryCompare
Dim Key As Variant
Dim r As Long
For r = 1 To UBound(Data, 1)
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next r
Dim rCount As Long: rCount = .Count
If rCount = 0 Then Exit Sub
ReDim Data(1 To rCount, 1 To 1)
r = 0
For Each Key In .Keys
r = r + 1
Data(r, 1) = Key
Next Key
End With
.Resize(rCount).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents ' clear below
End With
End With
End Sub
I have the below data in excel [which contains hundreds of rows]:
I am trying to find/map the words in the column "Form Word" (columnA) against the column "Form Word Orig." (columnC) and retrieve the root word which matches between "Root Results" (columnB) and "Root Results - Multiple Options" (columnD).
Note: The solution needs to find the matching ROOT from the several options (columnD) which are grouped by the Form word (columnC)
The solution would generate results something like this following:
If you could help provide a formula OR Visual Basic based solution I would be grateful.
Thank you in advance.
Try the next code, please:
Sub testFind_Mapp_Col()
Dim sh As Worksheet, arr1 As Variant, arr2 As Variant, i As Long, j As Long
Set sh = ActiveSheet 'use here your sheet
arr1 = sh.Range("A2:B" & sh.Range("A" & Rows.count).End(xlUp).Row).Value
arr2 = sh.Range("C2:E" & sh.Range("C" & Rows.count).End(xlUp).Row).Value
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i, 1) = arr2(j, 1) Then
If UCase(arr2(j, 2)) = Ucase(arr1(i, 2)) Then arr2(j, 3) = arr1(i, 2): Exit For
End If
Next j
Next i
sh.Range("C2").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
End Sub
I have a very large data block in an excel spreadsheet (100,000 rows by 30 columns).
The first column can have one of only six different values (CAT1..CAT6).
I need to split the content in 6 spreadsheets in the same book.
I load the source range in a source variant and split it in target variant, which I write in target sheets.
Code is along this lines:
Sub TestVariant()
Dim a, b, c As Variant
Dim i, j, k As Variant
Worksheets("Sheet1").Activate
a = Worksheets("Sheet1").Range("A1:AD100000").Value
ReDim b(UBound(a, 1), UBound(a, 2))
ReDim c(UBound(a, 1), UBound(a, 2))
j = 1
k = 1
For i = 1 To UBound(a, 1)
Select Case a(i, 1)
Case "CAT01"
b(j, 1) = a(i, 1)
'..
b(j, 30) = a(i, 30)
j = j + 1
Case Else
c(k, 1) = a(i, 1)
'..
c(k, 30) = a(i, 30)
k = k + 1
End Select
Next i
Worksheets("Sheet2").Range("A1").Resize(UBound(b, 1), UBound(b, 2)) = b
Worksheets("Sheet3").Range("A1").Resize(UBound(c, 1), UBound(c, 2)) = c
End Sub
Now for the questions:
Is there a way to copy one "row" at a time from the source variant to the target variant? Something like
b(j,) = a(i,)
Is there a way to simply redim the target variants to the data content (initially I just DIM to match the source but each target variant will obiously have less content than the source
Is there any other approach to the split problem more efficient? (collections? keys?)
Any suggestions will be most appreciated.
Thanks for reading
Cris
a combination of Sort() and Autofilter() methods of Range object should be quite fast:
Option Explicit
Sub TestVariant()
Dim iCat As Long
With Worksheets("Sheet1")
With .Range("AD1", .Cells(.Rows.COUNT, 1).End(xlUp))
.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes ', SortMethod:=xlPinYin, DataOption1:=xlSortNormal, MatchCase:=False, Orientation:=xlTopToBottom
For iCat = 1 To 6
.AutoFilter Field:=1, Criteria1:="CAT0" & iCat '<--| filter its columns A on current "CAT"
If Application.WorksheetFunction.Subtotal(103, .Columns(1).Cells) > 1 Then '<--| if any cell filtered other than header
With .Offset(1).Resize(.Rows.COUNT - 1).SpecialCells(xlCellTypeVisible)
GetWorkSheet("CAT0" & iCat).Range("A1").Resize(.Rows.COUNT, .Columns.COUNT).Value = .Value
End With
End If
Next iCat
End With
.AutoFilterMode = False
End With
End Sub
Function GetWorkSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetWorkSheet = Worksheets(shtName)
If GetWorkSheet Is Nothing Then
Set GetWorkSheet = Worksheets.Add
GetWorkSheet.name = shtName
End If
End Function
I am using the Concatenation code Below, it works wonderfully.
The problem is that the column of concatenated cells throws a error "Type mismatch in a different Macro that matches columns (I have used the matching macro extensively) even though the concatenated column is not one of the matching columns of the matching macro.
If I delete the column of concatenated cells the matching Macro work fine.
The error ocrurs at this point in the matching macro
wsPB.Range("A" & j).Resize(1, sLC).Offset(1, 10).Value = Application.Index(arrS, i, 0)
I am pretty sure the problem is:
Application.Index(arrS, i, 0)
Is their a way to get the Concatenate code below to not produce the `Type mismatch" when it encounters:
Application.Index(arrS, i, 0)
I do not see anything odd about the way the ConCat code post back the concatenated cells to the page with
.Value = a
any help or insight is greatly appriciated
Thank you
Sub ConCat()
Dim rng As Range, r As Range, i As Long
Set rng = Range("B2,A2,D2,N2,L2")
If rng Is Nothing Then Exit Sub
With Cells(1).CurrentRegion
ReDim a(1 To .Rows.Count, 1 To 2)
a(1, 1) = .Cells(1, 1).Value
a(1, 2) = "Concat"
For i = 2 To .Rows.Count
a(i, 1) = .Cells(i, 1).Value
For Each r In rng
If .Cells(i, r.Column) <> "" Then
a(i, 2) = a(i, 2) & IIf(a(i, 2) = "", "", "|") & _
.Cells(i, r.Column).Value
End If
Next
Next
With .Offset(, .Columns.Count + 1).Resize(, 2)
.Value = a
End With
End With
End Sub
Turns out that some of the cells in the sheet were over the 254 char limit and this was causing the error 13 thrown by Application.Index(arrS, i, 0) in the maching function and had nothing to do with the ConCat code
The fix was to re-write the Matching function without using Application.Index(arrS, i, 0)