I have an excel function as follows-
IF(B3="","",IF(AND(G3="NA",F3="Qualified"),"New to Qualified",
IF(AND(G3="NA",F3<>"Qualified"),CONCATENATE("New to Qualified and ",F3),
IF(AND(G3<>"NA",F3="Qualified"),IF(H3<>G3,"TCV Change","Same"),
IF(AND(G3<>"NA",F3<>"Qualified"),IF(H3="NA","TCV Change",IF(H3<>G3,CONCATENATE("TCV Change and ",F3),F3)))))))
I am trying to replicate the same in VBA as-
Sub CC()
Dim str1 As String
Dim str2 As String
str1 = "New to Qualified and" & Range("F3:F100")
str2 = "TCV Change and" & Range("F3:F100")
Range("J3:J100").Value = IIf(Application.WorksheetFunction.And(Range("G3:G100") = "NA", Range("F3:F100") = "Qualified"), "New to Qualified", _
IIf(Application.WorksheetFunction.And(Range("G3:G100") = "NA", Range("F3:F100") <> "Qualified"), str1, _
IIf(Application.WorksheetFunction.And(Range("G3:G100") <> "NA", Range("F3:F100") = "Qualified"), IIf(Range("H3:H100") <> Range("G3:G100"), "TCV Change", "Same"), _
IIf(Application.WorksheetFunction.And(Range("G3:G100") <> "NA", Range("F3:F100") <> "Qualified"), IIf(Range("H3:H100") = "NA", "TCV Change", IIf(Range("H3:H100") <> Range("G3:G100"), str2, Range("F3:F100")))))))
End Sub
However I'm getting an error on the last line- "Compile Error- Argument not optional"
Please help with the same.
This code might look more complicated at first but this is a "more VBA way" to do it. Doing this in VBA you will need a loop, since you can't just copy down the cells like you can in the worksheet. I usually avoid using WorksheetFunction. The following code will put all your values into an array and produce an array arrJ filled with the results. You do not need to approach this with arrays, but I would recommend using the If - ElseIf - Else structure I provided below, since it makes the code much easier to read, understand and modify.
Sub CC()
Dim str1 As String, str2 As String
str1 = "New to Qualified and "
str2 = "TCV Change and "
Dim arrB As Variant, arrF As Variant, arrG As Variant, arrH As Variant 'rename these to describe your data instead of columns
arrB = ActiveSheet.Range("B3:B100").Value2
arrF = ActiveSheet.Range("F3:F100").Value2
arrG = ActiveSheet.Range("G3:G100").Value2
arrH = ActiveSheet.Range("H3:H100").Value2
Dim rngJ As Range
Set rngJ = ActiveSheet.Range("J3:J100")
Dim strResult As String
Dim arrJ As Variant
ReDim arrJ(LBound(arrB) To UBound(arrB), 1 To 1)
For i = LBound(arrB) To UBound(arrB)
If arrB(i, 1) = vbNullString Then
strResult = vbNullString
Else
If arrG(i, 1) = "NA" And arrF(i, 1) = "Qualified" Then
strResult = "New to Qualified"
ElseIf arrG(i, 1) = "NA" And arrF(i, 1) <> "Qualified" Then
strResult = str1 & arrF(i, 1)
ElseIf arrG(i, 1) <> "NA" And arrF(i, 1) = "Qualified" Then
If arrH(i, 1) <> arrG(i, 1) Then
strResult = "TCV Change"
Else
strResult = "Same"
End If
ElseIf arrG(i, 1) <> "NA" And arrF(i, 1) <> "Qualified" Then
If arrH(i, 1) = "NA" Then
strResult = "TCV Change"
ElseIf arrH(i, 1) <> arrG(i, 1) Then
strResult = str2 & arrF(i, 1)
Else
strResult = arrF(i, 1)
End If
End If
End If
arrJ(i, 1) = strResult
Next i
rngJ.Value2 = arrJ
End Sub
Also, I find it useful to learn to do this kind of stuff in VBA the "proper way" (although I'm sure there are more elegant ways to solve this). This is in the long run of course, for a quick solution you might use something similiar to the code you posted.
A somewhat easier, and slower, way would be the following code. Again, please note that you will need to use a loop to achieve what you're trying to do.
Sub CC()
Dim str1 As String, str2 As String
str1 = "New to Qualified and "
str2 = "TCV Change and "
Dim i As Long
Dim strB As String, strF As String, strG As String, strH As String 'rename to describe your data
Dim strResult As String
For i = 3 To 100
With ActiveSheet
strB = .Cells(i, 2).Value2
strF = .Cells(i, 6).Value2
strG = .Cells(i, 7).Value2
strH = .Cells(i, 8).Value2
End With
If strB = vbNullString Then
strResult = vbNullString
Else
If strG = "NA" And strF = "Qualified" Then
strResult = "New to Qualified"
ElseIf strG = "NA" And strF <> "Qualified" Then
strResult = str1 & strF
ElseIf strG <> "NA" And strF = "Qualified" Then
If strH <> strG Then
strResult = "TCV Change"
Else
strResult = "Same"
End If
ElseIf strG <> "NA" And strF <> "Qualified" Then
If strH = "NA" Then
strResult = "TCV Change"
ElseIf strH <> strG Then
strResult = str2 & strF
Else
strResult = strF
End If
End If
End If
ActiveSheet.Cells(i, 10).Value2 = strResult
Next i
End Sub
not sure how exactly it should work with ranges but i tried to fix your code on cell level
try to use this:
str1 = "New to Qualified and" & Range("F7")
str2 = "TCV Change and" & Range("F7")
...
With Application.WorksheetFunction
Range("J7").Value = _
IIf(.And(Range("G7") = "NA", Range("F7") = "Qualified"), "New to Qualified", _
IIf(.And(Range("G7") = "NA", Range("F7") <> "Qualified"), str1, _
IIf(.And(Range("G7") <> "NA", Range("F7") = "Qualified"), IIf(.And(Range("H7") <> Range("G7")), "TCV Change", "Same"), _
IIf(.And(Range("G7") <> "NA", Range("F7") <> "Qualified"), IIf(Range("H7") = "NA", "TCV Change", IIf(Range("H7") <> Range("G7"), str2, Range("F7"))), ""))))
End With
Related
I have a private function that is designated to declare "uniqueValues" as a function that I use in one other sub routine in the module. The Code:
Private Function uniqueValues(InputRange As Range)
Dim cell As Range
Dim tempList As Variant: tempList = ""
Dim TFS As String
Set Eingaben = ThisWorkbook.Worksheets("Eingaben")
Set MainWs = ActiveWorkbook.Worksheets(Eingaben.Cells(3, 3).Value)
LastRow = MainWs.Range((Eingaben.Cells(4, 3).Value) & Rows.Count).End(xlUp).Row
TFS = Eingaben.Cells(12, 3).Value
Set InputRange = MainWs.Range(TFS & "2:" & TFS & LastRow)
For Each cell In InputRange
cell.Value = Replace(cell.Value, "/", "-")
cell.Value = Replace(cell.Value, "\", "-")
cell.Value = Replace(cell.Value, "?", "")
cell.Value = Replace(cell.Value, "*", "")
cell.Value = Replace(cell.Value, "[", "-")
cell.Value = Replace(cell.Value, "]", "")
If cell.Value <> "" Then
If InStr(1, tempList, cell.Value) = 0 Then
If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
End If
End If
Next cell
uniqueValues = Split(tempList, "|")
End Function
However, I have noticed that when I have other workbooks open (not active?), my whole sub routine stops working and when debugging its always stuck in this private function. I assume its applying this function to the other workbooks. I have thought of using a friend procedure or putting the sub and this function into a seperate module, but I dont think that would solve the issue. Any ideas?
I have a complicated split I need to do in VBA excel. I want to split each piece that starts "C:", includes "OCAK" and ends ".JPG" in range("C1") into A1,A2,A3... when click the button.
FROM THIS
TO THIS
I'm still doing research and testing, but I can't find a real viable solution. Any ideas would be greatly appreciated.
Private Sub buton_Click()
If Cells(1, "c").Text Like "C:*OCAK*.jpg*" Then
Dim jpgStart As Long
jpgStart = InStr(Cells(1, "c").Text, ".jpg")
Dim result As String
result = Left(Cells(1, "c").Text, jpgStart - 1)
Cells(1, "c").Offset(0, -2).Value = result
Else
Cells(1, "c").Offset(0, -2).Value = vbNullString
End If
End Sub
The problem is in the splitting actually. In the input, the new line should be used as a delimiter as well. Thus, consider changing the input a bit to something like this:
readCell = Worksheets(1).Cells(1, "C")
readCell = Replace(readCell, Chr(13) & Chr(10), " ")
readCell = Replace(readCell, vbCrLf, " ")
readCell = Replace(readCell, vbNewLine, " ")
readCell = Replace(readCell, vbLf, " ")
Once the input is fixed an array can be built of the units - myArray = Split(readCell). Looping through the array and using Like "C:*OCAK*.jpg" works quite well:
Public Sub TestMe()
Dim readCell As String
readCell = Worksheets(1).Cells(1, "C")
readCell = Replace(readCell, Chr(13) & Chr(10), " ")
readCell = Replace(readCell, vbCrLf, " ")
readCell = Replace(readCell, vbNewLine, " ")
readCell = Replace(readCell, vbLf, " ")
Dim myArray As Variant
myArray = Split(readCell)
Dim myVar As Variant
Dim currentRow As Long: currentRow = 1
For Each myVar In myArray
If myVar Like "C:*OCAK*.jpg" Then
Worksheets(1).Cells(currentRow, "A") = myVar
currentRow = currentRow + 1
End If
Next
End Sub
In your button macro code loop the cells in column c; I have to assume you know how to set that up and do it. Then for each cell in that range:
with thisworkbook.worksheets("theNameOfYourSheet")
dim loopRange As Range
set loopRange=.Range(.Cells(1,3),.Cells(.UsedRange.Rows.Count,3))
end with
dim cell as Range
for each cell in loopRange
If cell.text Like "C:*.jpg*" Then
Dim jpgStart As Long
jpgStart = Instr(cell.text,".jpg")
Dim result As String
result= Left(cell.text,jpgStart-1)
cell.offset(0,-1).Value=result
Else
cell.offset(0,-1).Value = vbNullString
End If
Next
Split by vbLf
Split by a blank space character
Test against your result
Code:
Option Explicit
Sub GetOcak()
Dim arr As Variant
arr = Split(Cells(1, 3).Value, vbLf)
Dim i As Long
Dim j As Long
j = 1
For i = 0 To UBound(arr)
If Left(Split(arr(i), " ")(0), 7) = "C:\OCAK" And _
Right(Split(arr(i), " ")(0), 4) = ".jpg" Then
Cells(j, 1).Value = Split(arr(i), " ")(0)
j = j + 1
End If
Next i
End Sub
Private Sub CommandButton1_Click()
If Range("C4").Value <> "" & Range("D4").Value <> "" & Range("E4").Value <> "" & Range("F4").Value <> "" & Range("G4").Value <> "" & Range("H4").Value <> "" & Range("I4").Value <> "" Then
Set i = Sheets("Sheet2")
Set e = Sheets("Sheet3")
Dim d
Dim j
j = 3
Do Until IsEmpty(e.Range("C" & j))
If e.Range("C" & j, "F" & j) = i.Range("C4:F4") Then
If e.Range("G" & j) Is Nothing Then
e.Range("G" & j, "I" & j) = i.Range("G4:I4")
Else
End If
Else
i.Range("C4:I4").Copy
e.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
j = j + 1
Loop
Else
End If
End Sub
Your Type Missmatch is because you are comparing Ranges with more than one cell like this:
If e.Range("C" & j, "F" & j) = i.Range("C4:F4") Then
VBA does not know what to answer as it does not know what do you expect to see, when you compare 4 cells with 4 cells.
In order to make something meaningful, you should implement a function, that compares the ranges. Something like this to get you started:
Public Function CompareRanges(rngA As Range, rngB As Range) As Boolean
If rngA.Count <> rngB.Count Then
CompareRanges = False
Exit Sub
Else
'loop through the cells of rngA and compare them with rngB
End If
End Function
The following code searches column A(sorted) for an item# and each time it finds it, the corresponding B, C & D column are entered into 3 listboxes. I would like to use a 3-column listbox. Any help?
Private Sub cmdSearch_Click()
Dim Response As Long
Dim NotFound As Integer
Dim arr As Variant
Dim i As Long
Dim str1 As String, str2 As String, str3 As String
NotFound = 0
ActiveWorkbook.Sheets("Items").Activate
Response = Val("0" & Replace(txtItemNumber.Text, "-", ""))
If Response <> False Then
With ActiveSheet
arr = .Range("A2:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
For i = 1 To UBound(arr)
If arr(i, 1) = Response Then
str1 = IIf(str1 = "", arr(i, 2), str1 & "|" & arr(i, 2))
str2 = IIf(str2 = "", arr(i, 3), str2 & "|" & arr(i, 3))
str3 = IIf(str3 = "", arr(i, 4), str3 & "|" & arr(i, 4))
End If
Next
If str1 = "" Then
MsgBox "Item Number Not Found!", vbExclamation
NotFound = 1
Else
Frame1.Visible = True
ListBox1.List = Split(str1, "|")
ListBox2.List = Split(str2, "|")
ListBox3.List = Split(str3, "|")
End If
End If
End Sub
Thanks for any help...
This should do it:
Change:
If str1 = "" Then
MsgBox "Item Number Not Found!", vbExclamation
NotFound = 1
Else
Frame1.Visible = True
ListBox1.List = Split(str1, "|")
ListBox2.List = Split(str2, "|")
ListBox3.List = Split(str3, "|")
End If
to:
If str1 = "" Then
MsgBox "Item Number Not Found!", vbExclamation
NotFound = 1
Else
Frame1.Visible = True
ListBox1.Clear 'to avoid errors
ListBox1.ColumnCount = 3
For i = 0 To UBound(Split(str1, "|"))
ListBox1.AddItem Split(str1, "|")(i)
ListBox1.List(i, 1) = Split(str2, "|")(i)
ListBox1.List(i, 2) = Split(str3, "|")(i)
Next
End If
hint: you may change ColumnWidths
however... to leave you some work, i suggest to merge it with your arr-part...
just using my solution would be a waste :D
I'm in the process of looping through an Excel spreadsheet and combining all the cells into a string, which I did. Now I need to format the string with XML tags before I send it for upload, and I'm having some difficulty working the tagging into the loop correctly. It seems like it is almost working, but a few of the tags are not going in the correct place. Any help would be much appreciated.
Code:
Public file As String
Sub locate_file()
Dim sheet1_95 As String
Dim theRange As Range
Dim strVal As String
Dim wb As Workbook
Dim counterDT As Integer
Dim counterSVR As Integer
Dim counterMB As Integer
Dim outputStr As String
'prompt user for location of other excel sheet'
file = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
Set wb = Workbooks.Open(file)
Dim cell As Range
'initializing the xml string'
strVal = "<root>"
Sheets("DT").Activate
counterDT = 1
For Each cell In ActiveSheet.UsedRange.Cells
'this first if-block is just excluding the few header cells from the data collection'
If cell.Value <> "SKU" And cell.Value <> "P Number" And cell.Value <> "Month" _
And cell.Value <> "DP Dmd" And cell.Value <> "Vertical" Then
If cell.Column = "1" Then
strVal = strVal & "<item><sku>" & cell.Value & "</sku>"
ElseIf cell.Column = "2" Then strVal = strVal & "<pnum>" & cell.Value & "</pnum>"
ElseIf cell.Column = "3" Then strVal = strVal & "<month>" & cell.Value & "</month>"
ElseIf cell.Column = "4" Then strVal = strVal & "<forecast>" & cell.Value & "</forecast>"
Else: strVal = strVal & "<vertical>" & cell.Value & "</vertical>"
End If
counterDT = counterDT + 1
If cell.Row <> 1 Then
If counterDT Mod 6 = 0 Then
strVal = "<item>" & strVal & "<percent>" & category.percent(cell, "DT") & "</percent>"
Else: End If
Else: End If
End If
Next
strVal = strVal & "</root>"
So basically the problem is, this loop/nested if is printing like 30 "item" tags at the very beginning of the string and I'm not sure why.
For some other information, the Excel sheet is 6 columns, and will always be 6.
When I'm creating xml tags, I like to move the actual tagging into a separate function. The upside is that it ensures my tags match. The downside is that you don't "apply" the tags until the end. Tags like item and root are done after all the tags within them are done. Here's an example:
Sub locate_file()
Dim sVal As String
Dim sRow As String
Dim wb As Workbook
Dim sh As Worksheet
Dim lCntDT As Long
Dim rCell As Range
Dim rRow As Range
Dim vaTags As Variant
gsFile = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If gsFile <> "False" Then
Set wb = Workbooks.Open(gsFile)
Set sh = wb.Sheets("DT")
vaTags = Array("sku", "pnum", "month", "forecast", "vertical")
lCntDT = 1
For Each rRow In sh.UsedRange.EntireRow
sRow = ""
If rRow.Cells(1) <> "SKU" Then
For Each rCell In Intersect(sh.UsedRange, rRow).Cells
If rCell.Column <= 4 Then
sRow = sRow & TagValue(rCell.Value, vaTags(rCell.Column - 1))
Else
sRow = sRow & TagValue(rCell.Value, vaTags(UBound(vaTags)))
End If
Next rCell
lCntDT = lCntDT + 1
If rRow.Row <> 1 And lCntDT Mod 6 = 0 Then
sVal = sVal & TagValue("CatPct", "percent")
End If
sRow = TagValue(sRow, "item")
sVal = sVal & sRow & vbNewLine
End If
Next rRow
sVal = TagValue(sVal, "root")
End If
Debug.Print sVal
End Sub
Function TagValue(ByVal sValue As String, ByVal sTag As String) As String
TagValue = "<" & sTag & ">" & sValue & "</" & sTag & ">"
End Function