I am filling two arrays with values one for inclusion and the other for exclusion. All working to this point. The next part should take the values from each array and replace unwanted values with a blank space. This also works but only for the first value. I know i need a loop here but can't get my head around it. Any pointers would be helpful. If there is a better way, I'm all ears.
Sub Service_Symbols()
Application.ScreenUpdating = False
Dim StringArray() As String
Dim i As Long
Dim ii As Long
Dim iii As Long
For i = Sheet2.Cells(Rows.Count, 11).End(xlUp).Row To 2 Step -1
'Seperate multiple values in cells
If InStr(Cells(i, 11).Value, ",") <> 0 Then
StringArray() = Split(Cells(i, 11).Value, ",")
'Place selected values into array for inclusion
For ii = LBound(StringArray) To UBound(StringArray)
If IsInArray(StringArray(), "1") Or IsInArray(StringArray, "4") Or IsInArray(StringArray, "5") Or IsInArray(StringArray, "6") Or IsInArray(StringArray, "7") Or IsInArray(StringArray, "8") Then
result = Join(StringArray(), " ")
End If
Next ii
'Place selected values into array for removal
For iii = LBound(StringArray) To UBound(StringArray)
ResultDel = StringArray(iii)
If InStr(ResultDel, "2") <> 0 Or InStr(ResultDel, "3") <> 0 Or InStr(ResultDel, "9") <> 0 Or InStr(ResultDel, "11") <> 0 Then
del = ResultDel
Debug.Print i; ResultDel
End If
Next iii
'This section not working. Needs to be looped
'Remove unwanted values
ServiceSym = Trim(Replace(Replace(Replace(result, del, ""), del, ""), " ", " "))
ServiceSym = Replace(ServiceSym, " ", ",")
'Sheet1.Range("G" & i).Value = ServiceSym
Debug.Print i; ServiceSym
'Debug.Print result
'Debug.Print i; del
'End of this section not working. Needs to be looped
'transfer selected single values in cells
ElseIf Sheet2.Range("K" & i).Value = "1" Or Sheet2.Range("K" & i).Value = "4" Or Sheet2.Range("K" & i).Value = "5" Or Sheet2.Range("K" & i).Value = "6" Or Sheet2.Range("K" & i).Value = "7" Or Sheet2.Range("K" & i).Value = "8" Then
result2 = Sheet2.Range("K" & i).Value
'Sheet1.Range("G" & i).Value = result2
Debug.Print i; result2
End If
Next i
Application.ScreenUpdating = True
'Call More_Services_Symbols 'Run the more services sub
End Sub
Adding this sub and replacing the section that is not working with a call to the sub should work.
Sub RemoveUnwantedValues(ByRef result As String, del)
Dim i As Integer
Dim arrResult() As String
arrResult = Split(result, " ")
For i = LBound(arrResult) To UBound(arrResult)
arrResult(i) = Trim(Replace(Replace(Replace(arrResult(i), del, ""), del, ""), " ", " "))
arrResult(i) = Replace(arrResult(i), " ", ",")
Next i
End Sub
You can call it this way: RemoveUnwantedValues result, del
Thanks for your help. It turns out i was over complicating things.
All i ended up needing to do was remove the join on result remove loop iii and place If instr, del & ServiceSym inside of loop ii.
Sub Service_Symbols()
Application.ScreenUpdating = False
Dim StringArray() As String
Dim i As Long
For i = Sheet2.Cells(Rows.Count, 11).End(xlUp).Row To 2 Step -1
'Seperate multiple values in cells
If InStr(Cells(i, 11).Value, ",") <> 0 Then
StringArray() = Split(Cells(i, 11).Value, ",")
'Place selected values into array for inclusion
For ii = LBound(StringArray) To UBound(StringArray)
If IsInArray(StringArray(), "1") Or IsInArray(StringArray, "4") Or IsInArray(StringArray, "5") Or IsInArray(StringArray, "6") Or IsInArray(StringArray, "7") Or IsInArray(StringArray, "8") Then
result = StringArray(ii)
'Debug.Print i; result
End If
If InStr(result, "2") <> 0 Or InStr(result, "3") <> 0 Or InStr(result, "9") <> 0 Or InStr(result, "11") <> 0 Then
del = result
'Debug.Print i; "del-"; del
End If
ServiceSym = Replace(result, del, "")
'Sheet1.Range("G" & i).Value = ServiceSym
Debug.Print i; ServiceSym
Next ii
'transfer selected single values in cells
ElseIf Sheet2.Range("K" & i).Value = "1" Or Sheet2.Range("K" & i).Value = "4" Or Sheet2.Range("K" & i).Value = "5" Or Sheet2.Range("K" & i).Value = "6" Or Sheet2.Range("K" & i).Value = "7" Or Sheet2.Range("K" & i).Value = "8" Then
result2 = Sheet2.Range("K" & i).Value
'Sheet1.Range("G" & i).Value = result2
Debug.Print i; result2
End If
Next i
Application.ScreenUpdating = True
'Call More_Services_Symbols 'Run the more services sub
End Sub
Related
I've made two different scripts in VBA to count the frequency of words contained in a CSV. Both scripts run fine, but I get different numbers for each word and I don't know why. Here are some of the steps that lead to the moment when the difference appears
Script 1:
Sub Dict_Array_1()
Dim Wb As Workbook, Wb1 As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet
Dim Fd As Office.FileDialog
Dim StrFile As String
Dim i As Long, a As Long, LastR As Long
Dim Arr() As Variant
Dim Ban_() As String, T As String
Dim Ban As Object, Dict As Object
Dim Carac As Variant, w As Variant, Key As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Set Wb = ActiveWorkbook
Set Ws = Wb.ActiveSheet
'---------- CSV ---------------------------------------------------------------------------------------------------------------
Set Fd = Application.FileDialog(msoFileDialogFilePicker)
With Fd
.AllowMultiSelect = False
.Title = "Select doc"
.Filters.Clear
.Filters.Add "Doc CSV (*.csv)", "*.csv"
If .Show Then
On Error GoTo ErrOpen 'ignore this
Set Wb1 = Workbooks.Open(.SelectedItems(1), ReadOnly:=True, Local:=False)
On Error GoTo 0
Set Ws1 = Wb1.Sheets(1)
With Ws1
LastR = .Cells(.Rows.Count, "S").End(xlUp).Row
Arr = .Range(Cells(1, 19), Cells(LastR, 19)).Value2
End With
Wb1.Close 0
Set Wb1 = Nothing
Set Ws1 = Nothing
Else
Exit Sub
End If
End With
'---------------------------------------- COUNT ----------------------------------------------------------------------------------------------------
'Array with words i want to ban
Ban_ = Split("word1,word2,word3,etc", ",")
'Array with caract i want to ban
Carac = Array(".", ",", ";", ":", "!", "#", "$", "%", "&", "(", ")", "- ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*", ">>", "»", "«")
Set Ban = CreateObject("Scripting.Dictionary") 'need late binding
Ban.CompareMode = vbTextCompare 'case insensitive
For i = 0 To UBound(Ban_)
Ban.Add Ban_(i), 1
Next i
Erase Ban_
'Dict to count words
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare 'case insensitive
For a = 1 To UBound(Arr, 1)
If Not IsError(Arr(a, 1))
T = Arr(a, 1)
For i = 0 To UBound(Carac)
T = Replace(T, Carac(i), "", , , vbTextCompare)
Next i
T = Application.Trim(T)
For Each w In Split(T, " ")
If Not Ban.exists(w) Then
If Not Dict.exists(w) Then
Dict.Add w, 1
Else
Dict.Item(w) = Dict.Item(w) + 1
End If
End If
Next w
End If
Next a
Exit Sub
Erase Arr
Erase Carac
Set Ban = Nothing
Script 2 is basically the same, only difference is that I access the .CSV in another way:
Sub Dict_ADODB()
Dim Wb As Workbook, Wb1 As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet
Dim Fd As Office.FileDialog
Dim StrFile As String
Dim i As Long, a As Long, LastR As Long
Dim Arr() As Variant
Dim Ban_() As String, T As String
Dim Ban As Object, Dict As Object
Dim Carac As Variant, w As Variant, Key As Variant
Dim ObjC As Object, ObjR As Object 'Object Connection / Object Recordset
Const adOpenStatic = 3
Const adLockOptimistic = 3
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Set Wb = ActiveWorkbook
Set Ws = Wb.ActiveSheet
'---------- CSV ---------------------------------------------------------------------------------------------------------------
Set Fd = Application.FileDialog(msoFileDialogFilePicker)
With Fd
.AllowMultiSelect = False
.Title = "Select doc"
.Filters.Clear
.Filters.Add "Doc CSV (*.csv)", "*.csv"
If .Show Then
'----------- ADODB ---
Set ObjC = CreateObject("ADODB.Connection")
Set ObjR = CreateObject("ADODB.RecordSet")
On Error GoTo ErrOpen
ObjC.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & .InitialFileName & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited;CharacterSet=65001"""
On Error GoTo 0
'I just need one column
ObjR.Open "SELECT Message FROM " & Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\")) & _
" WHERE Message IS NOT NULL", _
ObjC, adOpenStatic, adLockOptimistic
Arr = ObjR.GetRows()
ObjR.Close
ObjC.Close
Set ObjR = Nothing
Set ObjC = Nothing
Else
Exit Sub
End If
End With
'---------------------------------------- COUNT ----------------------------------------------------------------------------------------------------
'Array with word I don't need
Ban_ = Split("word1,word2", ",")
Carac = Array(".", ",", ";", ":", "!", "#", "$", "%", "&", "(", ")", "- ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*", ">>", "»", "«")
Set Ban = CreateObject("Scripting.Dictionary")
Ban.CompareMode = vbTextCompare
For i = 0 To UBound(Ban_)
Ban.Add Ban_(i), 1
Next i
Erase Ban_
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare 'case insensitive
For a = 0 To UBound(Arr, 2)
If Not IsError(Arr(0, a)) Then
T = Arr(0, a)
For i = 0 To UBound(Carac)
T = Replace(T, Carac(i), "", , , vbTextCompare)
Next i
T = Application.Trim(T)
For Each w In Split(T, " ")
If Not Ban.exists(w) Then
If Not Dict.exists(w) Then
Dict.Add w, 1
Else
Dict.Item(w) = Dict.Item(w) + 1
End If
End If
Next w
End If
Next a
Erase Arr
Erase Carac
Set Ban = Nothing
Exit Sub
Here you go. When I do dict.count I do find that the total number of entries is different, which is only partly explained by the use of "WHERE Message IS NOT NULL". Any idea why would be greatly appreciated!
The best case to see what is happening is to write some log this line:
Dict.Add w, 1
E.g., if the values are up to 200, then write:
Dim cnt as long
Dict.Add w, 1
cnt = cnt + 1
Debug.Print cnt, w
If the values are above 200, then only the last 200 would be displayed on the immediate window, thus it will not help you a lot. You can build a String with the log and print the String in a Notepad exactly with the same.
Dim cnt as Long
Dim logString as String
Dict.Add w, 1
cnt = cnt + 1
logString = logString & VbCrLF & cnt, w
And at the end CreateLogFile logString:
Sub CreateLogFile(Optional strPrint As String)
Dim fs As Object
Dim obj_text As Object
Dim str_filename As String
Dim str_new_file As String
Dim str_shell As String
str_new_file = "\tests_info\"
str_filename = ThisWorkbook.Path & str_new_file
If Dir(ThisWorkbook.Path & str_new_file, vbDirectory) = vbNullString Then
MkDir ThisWorkbook.Path & str_new_file
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set obj_text = fs.CreateTextFile(str_filename & "\sometext.txt", True)
obj_text.writeline (strPrint)
obj_text.Close
str_shell = "C:\WINDOWS\notepad.exe "
str_shell = str_shell & str_filename & "\sometext.txt"
Shell str_shell
End Sub
Alright, using a Schema.ini seems to have fixed my issue. Something that is not clear in the documentation is that one should set "colX= Y Type" for each column in the CSV until the one he wants to select (at first I only set "Col19=Message" but it failed because the previous columns where not set...).
I'm sharing the relevant part of the code for anyone interested (Excel 2010 / X86 version):
Set fs = CreateObject("Scripting.FileSystemObject")
Set obj_text = fs.CreateTextFile(.InitialFileName & "\Schema.ini", True)
obj_text.write ("[" & Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\")) & "]" & vbNewLine & _
"ColNameHeader=False" & vbNewLine & _
"CharacterSet=65001" & vbNewLine & _
"Format=CSVDelimited" & vbNewLine & _
"DecimalSymbol=." & vbNewLine & _
"Col1=1 Text" & vbNewLine & _
"Col2=2 Text" & vbNewLine & _
"Col3=3 Text" & vbNewLine & _
"Col4=4 Text" & vbNewLine & _
"Col5=5 Text" & vbNewLine & _
"Col6=6 Text" & vbNewLine & _
"Col7=7 Text" & vbNewLine & _
"Col8=8 Text" & vbNewLine & _
"Col9=9 Text" & vbNewLine & _
"Col10=10 Text" & vbNewLine & _
"Col11=11 Text" & vbNewLine & _
"Col12=12 Text" & vbNewLine & _
"Col13=13 Text" & vbNewLine & _
"Col14=14 Text" & vbNewLine & _
"Col15=15 Text" & vbNewLine & _
"Col16=16 Text" & vbNewLine & _
"Col17=17 Text" & vbNewLine & _
"Col18=18 Text" & vbNewLine & _
"Col19=GOODONE Memo") 'set all the previous cols until the one I need!
obj_text.Close
Set ObjC = CreateObject("ADODB.Connection")
Set ObjR = CreateObject("ADODB.RecordSet")
ObjC.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & .InitialFileName & ";" & _
"Extended Properties=""text;HDR=No;"""
ObjR.Open "SELECT GOODONE FROM " & Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\")), _
ObjC, 0, 1
Arr = ObjR.GetRows()
I have two tables that have an identical column structure where the information passed from a different department is put into the first template.
I want to look at the SKU from Table 1 and pass back everything that matches on that row in Table 2 - whilst ignoring any SKU code that is not on Table 1.
Graphical illustration of problem
The code is part of a larger sub (variables are declared prior etc.) which uses a scripting dictionary and then goes through a For loop - but this is not efficient:
Set dlCD1 = CreateObject("Scripting.Dictionary")
Row = 1
On Error GoTo Error
For Each cCD1 In Sheets("TABLE 2 SHEET").Range("c1:c" & MaxLineMPS)
tmpCD1 = Trim(cCD1.Value)
If Len(tmpCD1) < 10 Then tmpCD1 = "0" & tmpCD1
If Len(tmpCD1) > 0 Then dlCD1(tmpCD1) = dlCD1(tmpCD1) + 1
Next cCD1
For Each kCD1 In dlCD1.keys
With Sheets("TABLE 1 SHEET").Range("a2:x" & MaxLineMatrice)
.AutoFilter Field:=3, Criteria1:=kCD1
End With
If Sheets("TABLE 1 SHEET").Range("A2:A" & MaxLineMatrice).SpecialCells(xlCellTypeVisible).Count > 1 Then
With Sheets("TABLE 1 SHEET").Range("d$3:x" & "$" & MaxLineMatrice).SpecialCells(xlCellTypeVisible)
.Value = Sheets("TABLE 2 SHEET").Range("$d" & "$" & Row & ":$x" & "$" & Row).Value
End With
Else: End If
Row = Row + 1
Debug.Print kCD1, dlCD1(kCD1)
Next kCD1
Worksheets("TABLE 1 SHEET").AutoFilterMode = False
dlCD1.RemoveAll
I have thousands of SKU codes and this takes time to loop through. I am told that by doing this outside of the sheet I can do the job faster.
Here's my whole code:
Sub Month_RiempiFuturo()
Dim MinLineMatrice As Integer, MaxLineMatrice As Integer, MinLineMPS As Integer, MaxLineMPS As Integer, row As Integer
Dim dlCD1 As Object, cCD1 As Range, kCD1, tmpCD1 As String, dlCD2 As Object, cCD2 As Range, kCD2, tmpCD2 As String
Dim StartTime As Double, SecondsElapsed As Double
Dim PT1 As PivotTable
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Worksheets("TABLE SHEET 1").AutoFilterMode = False
Worksheets("TABLE SHEET 2").AutoFilterMode = False
StartTime = Timer
MinLineMatrice = 3
MaxLineMatrice = Sheets("TABLE SHEET 1").Range("A" & Rows.Count).End(xlUp).Row
MinLineMPS = 1
MaxLineMPS = Sheets("TABLE SHEET 2").Range("C" & Rows.Count).End(xlUp).Row
LastLineFINITY = Sheets("FINITY CAPACITY PLANNED").Range("A" & Rows.Count).End(xlUp).Row
Set PT1 = Worksheets("shift").PivotTables("Tabella_pivot1")
Worksheets("TABLE SHEET 1").Range("d3:x" & MaxLineMatrice).ClearContents
Set dlCD1 = CreateObject("Scripting.Dictionary")
Row = 1
On Error GoTo Error
For Each cCD1 In Sheets("TABLE SHEET 2").Range("c1:c" & MaxLineMPS)
tmpCD1 = Trim(cCD1.Value)
If Len(tmpCD1) < 10 Then tmpCD1 = "0" & tmpCD1
If Len(tmpCD1) > 0 Then dlCD1(tmpCD1) = dlCD1(tmpCD1) + 1
Next cCD1
For Each kCD1 In dlCD1.keys
With Worksheets("TABLE SHEET 1").Range("a2:x" & MaxLineMatrice)
.AutoFilter Field:=3, Criteria1:=kCD1
End With
If Sheets("TABLE SHEET 1").Range("A2:A" & MaxLineMatrice).SpecialCells(xlCellTypeVisible).Count > 1 Then
With Sheets("TABLE SHEET 1").Range("d$3:x" & "$" & MaxLineMatrice).SpecialCells(xlCellTypeVisible)
.Value = Sheets("TABLE SHEET 2").Range("$d" & "$" & Row & ":$x" & "$" & Row).Value
End With
Else: End If
Row = Row + 1
Debug.Print kCD1, dlCD1(kCD1)
Next kCD1
Worksheets("TABLE SHEET 1").AutoFilterMode = False
dlCD1.RemoveAll
Set dlCD1 = CreateObject("Scripting.Dictionary")
For Each cCD1 In Sheets("Finity capacity planned").Range("a2:a" & LastLineFINITY)
tmpCD1 = Trim(cCD1.Value)
If Len(tmpCD1) > 0 Then dlCD1(tmpCD1) = dlCD1(tmpCD1) + 1
Next cCD1
Set dlCD2 = CreateObject("Scripting.Dictionary")
For Each cCD2 In Sheets("Finity capacity planned").Range("b2:b" & LastLineFINITY)
tmpCD2 = Trim(cCD2.Value)
If Len(tmpCD2) > 0 Then dlCD2(tmpCD2) = dlCD2(tmpCD2) + 1
Next cCD2
For Each kCD1 In dlCD1.keys
With Sheets("Finity capacity planned").Range("A1:Ak" & LastLineFINITY)
.AutoFilter Field:=1, Criteria1:=kCD1
.AutoFilter Field:=2, Criteria1:=Array( _
dlCD2.keys()(0), dlCD2.keys()(2), dlCD2.keys()(4), dlCD2.keys()(6), dlCD2.keys()(8), dlCD2.keys()(10)), Operator:=xlFilterValues
End With
With Sheets("Finity capacity planned").Range("A2:Ak" & LastLineFINITY).SpecialCells(xlCellTypeVisible)
.Interior.ColorIndex = 15
End With
With Sheets("Finity capacity planned").Range("A1:Ak" & LastLineFINITY)
.AutoFilter Field:=1, Criteria1:=kCD1
.AutoFilter Field:=2, Criteria1:=Array( _
dlCD2.keys()(1), dlCD2.keys()(3), dlCD2.keys()(5), dlCD2.keys()(7), dlCD2.keys()(9), dlCD2.keys()(11)), Operator:=xlFilterValues
End With
With Sheets("Finity capacity planned").Range("A2:Ak" & LastLineFINITY).SpecialCells(xlCellTypeVisible)
.Interior.ColorIndex = 19
End With
Debug.Print kCD1, dlCD1(kCD1)
Next kCD1
Worksheets("Finity capacity planned").AutoFilterMode = False
dlCD1.RemoveAll
dlCD2.RemoveAll
With PT1
.RefreshTable
End With
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code including the time for user prompts to be acknowledged took " & SecondsElapsed & " Seconds", vbInformation, "McManus automation speed testing"
Exit Sub
Error:
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Something went wrong"
End Sub
You can use Find function to find the row number you are looking for. Then using this row number, you can have the data from that row.
I didn't dig into your code too much, because it is a bit messy. So considering that:
Blank Lookup sheet name is "TABLE 1 SHEET",
Master Lookup sheet name is "TABLE 2 SHEET",
Results sheet name is "TABLE 3 SHEET",
then you can try the following:
Sub findmydata()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, j As Long, foundrow As Long, lastrow1 As Long, lastrow2 As Long
Set ws1 = Sheets("TABLE 1 SHEET")
Set ws2 = Sheets("TABLE 2 SHEET")
Set ws3 = Sheets("TABLE 3 SHEET")
lastrow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow1
On Error Resume Next
foundrow = ws2.Range("A1:A" & lastrow2).Find(ws1.Cells(i, 1).Value).Row
If Err.Number = 91 Then
ws3.Cells(i, 1) = ws1.Cells(i, 1)
Else
For j = 1 To 4
ws3.Cells(i, j) = ws2.Cells(foundrow, j)
Next j
End If
Next
End Sub
I have the code below but I know it could be sped up by putting the data into an array which I don't know how. I'd appreciate any help.
Thanks In advance
For Each rngReportCell In rngReport
If rngReportCell = "" Then Exit For
If VBA.UCase(rngReportCell.Offset(0, 1).Value) = "X" Then
wkbSOR.Sheets("Dashboard").range("SSSFlag").Value = True
Else
wkbSOR.Sheets("Dashboard").range("SSSFlag").Value = False
End If
If rngRetrieveCell.Offset(0, 1).Value <> "" Then _
wkbSOR.Sheets(rngRetrieveCell.Value).range(rngRetrieveCell.Offset(0, 1).Value) _
= "'" & rngReportCell.Value
If rngReportCell.Offset(0, 2) <> "" And gRetrieveCell.Offset(0, 2).Value <> "" Then _
wkbSOR.Sheets(rngRetrieveCell.Value).range(rngRetrieveCell.Offset(0, 2).Value) _
= "'" & rngReportCell.Offset(0, 2).Value
TotalRows = range("Base_" & rngRetrieveCell).Rows.count
TotalCols = range("Base_" & rngRetrieveCell).Columns.count
'Copies values using range.value = range.value
range("A7").Offset(range("A7").CurrentRegion.Rows.count, 0).Resize(TotalRows, TotalCols).Value = _
wkbSOR.Sheets(rngRetrieveCell.Value).range("Base_" & rngRetrieveCell).Value
Next rngReportCell 'Store/Hyperion code
Maybe this will help you:
https://stackoverflow.com/questions/17859531/excel-vba-populate-array-with-range-from-specific-sheet
But essentially you will want to just import the range that you want into a 2-D array and iterate through as so (for example):
'Instantiate variant array
Dim arrValues() As Variant
arrValues = Sheet1.Range("A1:D10")
'Iterate through rows
For i = 1 To 10
'Iterate through columns
For j = 1 To 10
'your code here
Next
Next
I have a spreadsheet of data in multiple columns. In VBA, I am trying to set a value in each row depending on the data in any one of three of the other columns. It will always be an OR comparison between those data and will need to return one of five values.
So I have created five arrays (they are multidimensional due to reading them in as ranges, however, they could be one dimensional if needed, I suppose), and I was going to compare the three columns to those arrays using a bunch of IF-THEN statements to return the necessary value.
Creating the arrays was easy enough, but I have no idea how to create the IF-THEN process correctly. An example of the process would be something like:
IF A1 is in ArrayA THEN
D1="Dog"
ELSEIF A1 is in ArrayB THEN
D1="Cat"
ELSEIF B1 is in ArrayC THEN
D1="Bird"
ELSEIF B1 is in ArrayD THEN
D1="Monkey"
ELSEIF C1 is in ArrayE THEN
D1="Blue"
ELSE
D1="Other"
I am not sure if this is the most efficient way to accomplish what I am trying to do, so I am definitely open to suggestions for a different approach. Thank you.
Ok, here is how I got it working. Most of this came from another person, but they deleted their comment so I can't thank them.
arrCols = Array(arrA, arrB, arrC, arrD, arrE)
arrVals = Array("Dog", "Cat", "Bird", "Monkey", "Blue")
For i = 2 To rCnt
pID = Cells(i, 2).Value
pName = Cells(i, 3).Value
pGroup = Cells(i, 4).Value
ans = ""
For j = LBound(arrCols) To UBound(arrCols)
If Not IsError(Application.Match(pGroup, arrCols(j), 0)) Then
ans = arrVals(j)
Exit For
ElseIf Not IsError(Application.Match(pName, arrCols(j), 0)) Then
ans = arrVals(j)
Exit For
ElseIf Not IsError(Application.Match(pID, arrCols(j), 0)) Then
ans = arrVals(j)
Exit For
End If
Next j
Cells(i, 5) = IIf(ans = "", "Other", ans)
Next i
I created an array of arrays to search through. The i loop cycles through all rows. The j loop cycles through the arrays within the main array. The three IF statements are needed for checking the three different columns. The returned value is defaulted to "Other" unless it is found in one of the arrays.
The only thing I was able to add to this code was the stuff needed to check three different columns in the row.
Here is an example of how to do it without looping
If Len("," & Join(ArrayA, ",") & ",") <> Len("," & Replace(Join(ArrayA, ","), "," & Range("A1").Value & ",", "") & ",") Then
Range("D1").Formula = "Dog"
ElseIf Len("," & Join(ArrayB, ",") & ",") <> Len("," & Replace(Join(ArrayB, ","), "," & Range("A1").Value & ",", "") & ",") Then
Range("D1").Formula = "Cat"
ElseIf Len("," & Join(ArrayC, ",") & ",") <> Len("," & Replace(Join(ArrayC, ","), "," & Range("A1").Value & ",", "") & ",") Then
Range("D1").Formula = "Bird"
ElseIf Len("," & Join(ArrayD, ",") & ",") <> Len("," & Replace(Join(ArrayD, ","), "," & Range("A1").Value & ",", "") & ",") Then
Range("D1").Formula = "Monkey"
ElseIf Len("," & Join(ArrayE, ",") & ",") <> Len("," & Replace(Join(ArrayE, ","), "," & Range("A1").Value & ",", "") & ",") Then
Range("D1").Formula = "Blue"
Else
Range("D1").Formula = "Other"
End If
Join the array to a string then check the len against the len of the string with the keyword (Range("A1")) replaced with nothing. Put a comma on either side to make sure it is the full word (Don't want something like Catfish to return as a Cat)
And the same thing using InStr instead:
If InStr(1, "," & Join(ArrayA, ",") & ",", Range("A1").Value) > 0 Then
Range("D1").Formula = "Dog"
ElseIf InStr(1, "," & Join(ArrayB, ",") & ",", Range("A1").Value) > 0 Then
Range("D1").Formula = "Cat"
ElseIf InStr(1, "," & Join(ArrayC, ",") & ",", Range("A1").Value) > 0 Then
Range("D1").Formula = "Bird"
ElseIf InStr(1, "," & Join(ArrayD, ",") & ",", Range("A1").Value) > 0 Then
Range("D1").Formula = "Monkey"
ElseIf InStr(1, "," & Join(ArrayE, ",") & ",", Range("A1").Value) > 0 Then
Range("D1").Formula = "Blue"
Else
Range("D1").Formula = "Other"
End If
I have a problem writing an array to a .csv file. I found a way to create an array and to write it to a .csv file, but it gives an error #(arrayNumber(i) = mainWorkBook.Sheets("Sheet1").Range("A" & i).Value). I can't find why I can't write these values into the array. Because of this problem I also couldn't test if the writing to the .Csv file is the correct way. I hope someone can point me into the right direction. thanks in advance.
Sub Numbering()
Dim arrayNumber()
Dim arrayName()
Dim pathName As String
If ActiveSheet.Name = "OVERVIEW" Or ActiveSheet.Name = "Template" Or ActiveSheet.Name = "Develop" Or ActiveSheet.Name = "Schedule" Or ActiveSheet.Name = "Information" Or ActiveSheet.Name = "Announcements" Or ActiveSheet.Name = "Database" Then
MsgBox ("You can't extract the number and name to a csv file.")
Else
pathName = "C:" & "\textfile.csv"
Open pathName For Output As #1
Print #1, "Number Name"
ActiveSheet.Select
LastRow = ActiveSheet.Range("K1048555").End(xlUp).Row
ReDim Preserve arrayNumber(1 To LastRow)
ReDim Preserve arrayName(1 To LastRow)
j = 1
For i = 13 To LastRow
If ActiveSheet.Range("K" & i).Value = "1" Then
arrayNumber(i) = mainWorkBook.Sheets("Sheet1").Range("A" & i).Value
arrayName(i) = ActiveSheet.Range("Q" & i).Value
Print #1, " arrayNumber & "; " & arrayName"
j = j + 1
End If
Next
Close #1
MsgBox ("Done")
End If
End Sub
With some trying I have found the solution (code below).
Sub Numbering()
Dim arrayNumber()
Dim arrayName()
Dim pathName As String
If ActiveSheet.Name = "OVERVIEW" Or ActiveSheet.Name = "Template" Or ActiveSheet.Name = "Develop" Or ActiveSheet.Name = "Schedule" Or ActiveSheet.Name = "Information" Or ActiveSheet.Name = "Announcements" Or ActiveSheet.Name = "Database" Then
MsgBox ("You can't extract the number and name to a csv file.")
Else
pathName = "C:" & "\textfile.csv"
Open pathName For Output As #1
Print #1, "Number Name"
ActiveSheet.Select
LastRow = ActiveSheet.Range("K1048555").End(xlUp).Row
ReDim Preserve arrayNumber(1 To LastRow)
ReDim Preserve arrayName(1 To LastRow)
j = 1
For i = 13 To LastRow
If ActiveSheet.Range("K" & i).Value = "1" Then
arrayNumber(j) = ActiveSheet.Range("A" & i).Value
arrayName(j) = ActiveSheet.Range("Q" & i).Value
MsgBox (arrayNumber(j))
MsgBox (arrayName(j))
Print #1, arrayNumber(j) & "; " & arrayName(j)
j = j + 1
End If
Next
Close #1
MsgBox ("Done")
End If
End Sub
you migth consider:
Sub M_snb()
createobject("scripting.filesystemobject").createtextfile("C:\textfile.csv").write join([transpose(if(K13:K2000="","",A13:A2000&";"&K13:K2000))],vbcrlf)
end sub