I have a Multivalue field which stores a value in 0th index. I'm trying to split the values using comma separator but it's throwing an error as type mismatch while I split the values. All the variables is declared as Variant datatype but still it throws the "Type Mismatch" error.
Thanks in advance.
If Trim(doc.GetItemValue("fldPartNo_2")(0)) <> "" Then
arrPartNo = ArrayAppend(doc.GetItemValue("fldPartNo_1"), doc.GetItemValue("fldPartNo_2"))
Else
arrPartNo = doc.GetItemValue("fldPartNo_1")
End If
arrRecdQty = doc.GetItemValue("fldRecdQty")
arrUM = doc.GetItemValue("fldUM")
arr=Split(arrUM,",")
Dim n As Integer
n=0
Do Until arr=""
n=n+1
Loop
sno = sno+1
worksheet.cells(i,j).value= doc.Universalid
j=j+1
worksheet.cells(i,j).value=sno
j=j+1
'MsgBox(CStr(arrUM(0)))
For l=0 To n
worksheet.cells(i,j).value= arrPartNo(l)
j=j+1
worksheet.cells(i,j).value= arrUM(l)
j=j+1
worksheet.cells(i,j).value= arrRecdQty(l)
j=j+1
worksheet.cells(i,j).value= doc.Getitemvalue("fldReject_"+CStr(l+1))
j=j+1
If IsNumeric(Trim(arrRecdQty(l))) Then
If IsNumeric(Trim(doc.GetItemValue("fldReject_" + CStr(l + 1))(0))) Then
worksheet.cells(i,j).value= arrRecdQty(l) - doc.GetItemValue("fldReject_" + CStr(l + 1))(0)
j=j+1
Else
worksheet.cells(i,j).value= arrRecdQty(l)
j=j+1
End If
Else
worksheet.cells(i,j).value= ""
j=j+1
End If
Next
worksheet.cells(i,j).value= doc.GetItemValue("fldRemarks_" + CStr(l + 1))(0)
j=j+1
worksheet.cells(i,j).value= "N_MRN"
j=j+1
worksheet.cells(i,j).value= ""
j=j+1
worksheet.cells(i,j).value= ""
j=j+1
worksheet.cells(i,j).value= "True"
j=j+1
Set doc = vw.Getnextdocument(doc)
j = j + 1
sno=0
i = i + 1
j = 1
Wend
Get element 0 from arrUM first and then split the value by ","
arr=Split(arrUM(0),",")
Related
'Membuat shortcut sheet untuk lebih pendek
'Make shortcut
Set po = Sheets("Print Out")
Dim awal, Akhir As Integer
Dim j As Long
'mencantumkan N6 & O6 menjadi value acuan
'Make N6 & O6 as main value print
awal = po.Range("N6").Value
Akhir = po.Range("O6").Value
j = 0
'menjalankan menu pilih printer
'Show up print dialog and set "normal" print area (w/o) condition
Application.ScreenUpdating = False
Application.Dialogs(xlDialogPrinterSetup).Show
po.PageSetup.PrintArea = "$B$1:$L$57"
'perintah utama
'Main command to apply auto mass print
For i = awal To Akhir
With po
.Range("M1").Value = i + 0 + j
.Range("M2").Value = i + 1 + j
.Range("M3").Value = i + 2 + j
.Range("M4").Value = i + 3 + j
.PrintPreview
j = j + 3
End With
'jika mendeteksi N/A atau sejenisnya perintah akan berhenti
'If found #N/A or #REF or any error loop will stop to prevent loop printing even data already reach limit
If IsError(po.Range("C4")) Then Exit For
If IsError(po.Range("C18")) Then
po.PageSetup.PrintArea = "$B$1:$L$15"
Exit For
'Jika M4 lebih besar dari batas akhir (O6) maka perintah akan terhenti
'If m4 > than O6 then print area will change and stop the loop (THIS IS THE PROBLEM)
If po.Range("M4") + 2 > po.Range("O6") Then po.PageSetup.PrintArea = "$B$1:$L$43"
If po.Range("M3") + 3 > po.Range("O6") Then po.PageSetup.PrintArea = "$B$1:$L$29"
If po.Range("M2") + 4 > po.Range("O6") Then po.PageSetup.PrintArea = "$B$1:$L$15"
Next i
The macro I created as above, but there is a problem that I cannot overcome.
Like the following line:
If po.Range("M4") + 2 > po.Range("O6") Then po.PageSetup.PrintArea = "$B$1:$L$43"
Basically, the code above will adjust the "printarea" if it has crossed the limit I have set, but I want to add an "Exit for" command to stop the loop after the "If-then" criteria is met.`
I already tried to make
If po.Range("M4") + 2 > po.Range("O6") Then
po.PageSetup.PrintArea = "$B$1:$L$43
Exit for
but the "Exit for" code will run along with the printarea change, so my last page has not been printed yet. What I want is for the loop to stop after my last page is printed (where my last page will always be related to the "if then" above).
If...Then and Select Case
Option Explicit
Sub Test()
'Membuat shortcut sheet untuk lebih pendek
'Make shortcut
' Reference (set) the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference (set) the worksheet.
Dim po As Worksheet: Set po = wb.Worksheets("Print Out")
With po
'mencantumkan N6 & O6 menjadi value acuan
'Make N6 & O6 as main value print
Dim Awal As Long: Awal = .Range("N6").Value
Dim Akhir As Long: Akhir = .Range("O6").Value
'menjalankan menu pilih printer
'Show up print dialog and set "normal" print area (w/o) condition
Application.ScreenUpdating = False
Application.Dialogs(xlDialogPrinterSetup).Show
.PageSetup.PrintArea = "$B$1:$L$57"
Dim i As Long
Dim j As Long
'perintah utama
'Main command to apply auto mass print
For i = Awal To Akhir
.Range("M1").Value = i + 0 + j
.Range("M2").Value = i + 1 + j
.Range("M3").Value = i + 2 + j
.Range("M4").Value = i + 3 + j
.PrintPreview
j = j + 3
'jika mendeteksi N/A atau sejenisnya perintah akan berhenti
'If found #N/A or #REF or any error loop will stop to prevent loop printing even data already reach limit
If IsError(.Range("C4")) Then
' do nothing!
ElseIf IsError(.Range("C18")) Then
.PageSetup.PrintArea = "$B$1:$L$15"
Else
'Jika M4 lebih besar dari batas akhir (O6) maka perintah akan terhenti
'If m4 > than O6 then print area will change and stop the loop (THIS IS THE PROBLEM)
Select Case .Range("O6").Value
' This logic is wrong! All cases are the same:
' .Range("M4") + 2 = .Range("M3") + 3 = .Range("M2") + 4
Case Is < .Range("M4").Value + 2: .PageSetup.PrintArea = "$B$1:$L$43"
Case Is < .Range("M3").Value + 3: .PageSetup.PrintArea = "$B$1:$L$29"
Case Is < .Range("M2").Value + 4: .PageSetup.PrintArea = "$B$1:$L$15"
Case Else
' do nothing!?...
' ... or e.g.:
'MsgBox "Something went wrong. Add more cases.", vbCritical
End Select
End If
Next i
End With
End Sub
It looks like you miss the ELSE statement and END IF.
If po.Range("M4") + 2 > po.Range("O6") Then
po.PageSetup.PrintArea = "$B$1:$L$4"
Else
Exit for
End if
You can also use GOTO to get your program to continue from another place in your code. EXIT FOR will always forse your FOR loop to end.
If po.Range("M4") + 2 > po.Range("O6") Then
po.PageSetup.PrintArea = "$B$1:$L$4"
Else
GOTO ContinueHere
End if
' Code you want to skip
ContinueHere:
' Continues to code here
NEXT
So i had this code as my basic (i got this from ytb)
Dim awal, Akhir As Integer
awal = Range("N6").Value
Akhir = Range("O6").Value
If awal <= Akhir And awal >= 1 Then
Application.ScreenUpdating = False
For i = awal To Akhir Step 5
With Sheets("Print Out")
.Range("f8").Value = i
.Printpreview
End With
Next i
Else
MsgBox "Cek lagi Nomor yang akan dicetak...!!!!", vbCritical, "Cetak Halaman"
End If
From that code i try to add + 1 + 2 every value but that's not work, help me to know how to this code generate 5 cell every done with 1 .Printpreview
I have a sub where I want to submit data with a command button, and before it sends the data, it has a loop that checks every control on every page of the userform. If the control is visible, and it fits within the case, then check to see if it's blank and then place that control name into an array.
the loop starts, but once I hit my first case statement loop cmb*, it skips over and doesn't enter the loop.
What is going on here? I have used the Like operator to clear fields on a sheet before, not sure why this isnt working..
Private Sub CommandButton1_Click()
Dim icontrol As Control
Dim arrBlankFields As Variant
Dim i As Long, x As Long
For i = 0 To Me.MultiPage1.Pages.Count
If Me.MultiPage1.Pages(i).Visible = True Then
For Each icontrol In Me.Controls
If icontrol.Visible = True Then
Select Case icontrol.Name
Case icontrol.Name Like "Multi*"
Case icontrol.Name Like "lbl*"
Case icontrol.Name Like "txt*"
If icontrol.Value = "" Then
ReDim Preserve arrBlankFields(x)
arrBlankFields(x) = icontrol.Name
x = x + 1
End If
Case icontrol.Name Like "opt*"
If icontrol.Value = "" Then
ReDim Preserve arrBlankFields(x)
arrBlankFields(x) = icontrol.Name
x = x + 1
End If
Case icontrol.Name Like "cmb*"
If icontrol.Value = "" Then
ReDim Preserve arrBlankFields(x)
arrBlankFields(x) = icontrol.Name
x = x + 1
End If
End Select
Else
End If
Next
End If
Next i
If Len(arrBlankFields) > 0 Then
MsgBox arrBlankFields & " fields are empty, please go back and populate before sending data"
Else
End If
End Sub
My code loops through rows with data on one master-sheet and updates different sheets based on the category of the data on each row. When I run the macro, I can see the information temporarily flash where it should be pasted on the worksheet before disappearing. This does not happen where I have used the same copy/paste command before.
The beggining two loops with WOB and ROP will paste correctly while the custom loop does not. I have also tried making the Select Case into several elseif statements which has the same non-working result.
Sub SortData()
Dim Datasheet As Worksheet
Dim ROPsheet As Worksheet 'Rate of Penetration
Dim Customsheet As Worksheet
Dim WOBsheet As Worksheet 'Weight on Bit
Dim i As Long 'Used as counter to loop through compiled data sheet
Dim j As Long 'Used as counter for each Limiter tested
Dim LastRowCount As Long 'Finds number of rows for ending loop
Dim Limiter As String 'These are WOB, ROP, Custom ect.
Dim DepthCheck As Double 'Checks depth on individual limiter sheet with depth on data sheet
Dim DatetCheck As String 'Checks date on individual limiter sheet with depth on data sheet
Dim Depth As Double 'depth from data sheet
Dim Datet As String 'date from limiter sheet
Dim y As Double 'Used to progress through rows
Set Datasheet = Worksheets("Data")
Set ROPsheet = Worksheets("ROP")
Set Customsheet = Worksheets("Custom")
Set WOBsheet = Worksheets("WOB")
y = 1
i = 1
'_____________________________________Working_Code_Below__________________________________________________________
'Arbitrary Count for testing
For i = 1 To 100
y = y + 1
Limiter = Worksheets("Data").Cells(y, 2).Value
Depth = Worksheets("Data").Cells(y, 5).Value
Datet = Worksheets("Data").Cells(y, 6).Value
'WOB
If Limiter = "WOB" Then
j = 1
LastRowCount = WOBsheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Count
For j = 1 To LastRowCount
DepthCheck = Worksheets("WOB").Cells(j + 1, 5).Value
DatetCheck = Worksheets("WOB").Cells(j + 1, 6).Value
If DepthCheck <> Depth Or DatetCheck <> Datet Then
If j = LastRowCount Then
Datasheet.Range(Datasheet.Cells(y, 2), Datasheet.Cells(y, 13)).Copy Sheets("WOB").Cells(j + 1, 2)
GoTo EndLast
End If
Else
GoTo EndLast
End If
Next j
Else
GoTo ROPStart
End If
ROPStart:
If Limiter = "ROP" Then
j = 1
LastRowCount = ROPsheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Count
For j = 1 To LastRowCount
DepthCheck = Worksheets("ROP").Cells(j + 1, 5).Value
DatetCheck = Worksheets("ROP").Cells(j + 1, 6).Value
If DepthCheck <> Depth Or DatetCheck <> Datet Then
If j = LastRowCount Then
Datasheet.Range(Datasheet.Cells(y, 2), Datasheet.Cells(y, 13)).Copy Sheets("ROP").Cells(j + 1, 2)
GoTo EndLast
End If
Else
GoTo EndLast
End If
Next j
Else
GoTo CustomStart
End If
CustomStart:
j = 1
LastRowCount = Customsheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Count
Select Case Limiter
Case "WOB", "Balling", "RPM", "Vibrations", "Torque", "Buckling", "Differential Pressure", "Flow Rate", "Pump Pressure", "Well Control", "Directional", "Logging", "ROP"
GoTo EndLast
Case Else
For j = 1 To LastRowCount
DepthCheck = Worksheets("Custom").Cells(j + 1, D).Value
DatetCheck = Worksheets("Custom").Cells(j + 1, dt).Value
If DepthCheck <> Depth Or DatetCheck <> Datet Then
If j = LastRowCount Then
Datasheet.Range(Datasheet.Cells(y, 2), Datasheet.Cells(y, 13)).Copy Sheets("Custom").Cells(j + 1, 2)
GoTo EndLast
End If
Else
GoTo EndLast
End If
Next j
End Select
EndLast:
Next i
End Sub
No error messages appear.
PS. This is my first post so sorry if formatting is weird.
Welcome to SO and congratulations on your first post. One of these days I'll be there with you, I'm just looking for the perfect question that's all. Lack of courage has nothing to do with it, really, scout's honor. Pinky promise!
I've tried following your code and struggle quite a bit because of the nonlinear flow. The problem you describe sounds like the data is written and then overwritten. This would typically be caused by a superfluous loop, in your case it may be induced by GoTo.
Touching on the comments about finding the row count; this is a surprisingly nuanced subject with many different answers and the correct one dependent on your circumstances and needs. Most of the time I can use UsedRange, as in Sheet1.UsedRange.Rows.Count; but I predominately work on spreadsheets I maintain and keep things as tight as my knowledge allows at the time. I don't remember how long ago I bookmarked this website but I swear I used it daily for a couple months straight: OZGrid Excel Ranges And of course Chip Pearson is worth a call out CPearson Last Used Cell
Please take this last bit as constructive criticism and have a good laugh. When you try to follow this code and get lost, take a step back, look at your code, and find the same pattern - and stop doing it. Break the habit and break the habit hard. Some people, myself included have a near visceral reaction when trying to debug spaghetti code. Try to write linearly top down. You'll find that you understand your own code better, it's easier to keep track of your thoughts, and transfer those thoughts into code. It's a win, win, win situation. GoTo's are almost entirely unnecessary and really impede the progress of others trying to help; using one here or there can be a handy little shortcut in a 5 line function but are best avoided when your code requires scrolling.
Sub aProcedure()
GoTo T
V:
j = vbCancel
b = "point"
GoTo K
X2:
j = x
b = "before"
GoTo K
A1:
For i = VbMethod To vbCancel
b = DoThingWith(DoThingWith(b, 44), b)
Next
j = j * 3
a = DoThingWith(a, b)
GoTo Z
Z:
b = "times"
GoTo K
U2:
j = j + 1 - x
b = "has"
GoTo K
A2:
MsgBox DoThingWith(a)
Exit Sub
X1:
j = j + 1
b = "made"
GoTo K
T:
a = "this"
GoTo U1
K:
a = DoThingWith(a, b)
DoEvents
Select Case j
Case 0
GoTo A2
Case 1
GoTo U1
Case 2
GoTo U2
Case 3
GoTo W
Case 4
GoTo X1
Case 5
GoTo Y
Case Else
GoTo X2
End Select
W:
j = 2 * (j - 1)
b = "been"
GoTo K
Y:
b = "many"
GoTo A1
U1:
a = Replace(a, Left(a, 1), UCase(Left(a, 1)))
GoTo V
End Sub
Private Function DoThingWith(a, Optional b = 46, Optional c = 32)
If IsNumeric(b) Then
b = CInt(b)
c = CInt(c)
Select Case Asc(Right(a, 1))
Case b
DoThingWith = a & Chr(b - c - 1)
Case Else
DoThingWith = a & Chr(b)
End Select
ElseIf IsNumeric(c) Then
c = CInt(c)
DoThingWith = a & Chr(c) & b
Else
DoThingWith = a & b & c
End If
End Function
The output:
In VBA I've made an userform. It contains multiple text boxes in which the user can write text. In one text box the user is supposed to type in his last name. I've made a variable called lastname and then did lastname = LastnameBox.Value.
My question is:
If someone for example types de Vries, how can I change this in Vries, de. Or if someone types van de Voort van Zijp, I need to change this in Voort van Zijp, van de.
How could I make this possible in VBA?
I would try something along these lines. Not sure how you are requiring separation, I used "de" as this
Function NamesTest(strNameIn As String)
Dim a() As String
a = Split(strNameIn, "de")
a(0) = a(0) & " de"
NamesTest = a(1) & "," & a(0)
End Function
Here are two options. The first will pick up the last word and do the swap. It pays no attention to letter case.
Sub LastFirst()
Debug.Print RevLast("de Vries")
Debug.Print RevLast("van der Straat")
Debug.Print RevLast("van de drake")
End Sub
Function RevLast(Name)
LastName = Trim(Right(Replace(Name, " ", String(99, " ")), 99))
LenLastName = Len(LastName)
FirstPart = Left(Name, Len(Name) - (LenLastName + 1))
RevLast = LastName + ", " + FirstPart
End Function
The second only swaps of there is an uppercase letter.
Sub UppercaseFirst()
Name = "de Vries"
Name = "van der Straat"
Debug.Print RevUpper("de Vries")
Debug.Print RevUpper("van der Straat")
Debug.Print RevUpper("van de drake")
End Sub
Function RevUpper(Name)
FirstUpper = -1
On Error Resume Next
xStr = Trim(Rg.Value)
For j = Len(Name) To 1 Step -1
If (Asc(Mid(Name, j, 1)) < 91) And (Asc(Mid(Name, j, 1)) > 64) Then
FirstUpper = Len(Name) - j + 1
Exit For
End If
Next
If FirstUpper > 0 Then
LastName = Right(Name, FirstUpper)
FirstPart = Left(Name, Len(Name) - (FirstUpper + 1))
NewName = LastName + ", " + FirstPart
RevUpper = NewName
Else
RevUpper = "Invalid"
End If
End Function
Function RevNm(Name)
FirstUpper = -1
On Error Resume Next
xStr = Trim(Rg.Value)
For j = Len(Name) To 1 Step -1
If (Asc(Mid(Name, j, 1)) < 91) And (Asc(Mid(Name, j, 1)) > 64) Then
FirstUpper = Len(Name) - j + 1
Exit For
End If
Next
If FirstUpper > 0 Then
LastName = Right(Name, FirstUpper)
FirstPart = Left(Name, Len(Name) - (FirstUpper + 1))
NewName = LastName + ", " + FirstPart
RevNm = NewName
Else
RevNm = "Invalid"
End If
End Function
Here's a more general-purpose solution for the problem stated in the title (won't handle the specifics of inverting first name / last name, which is a different problem):
Public Function ReverseWords(ByVal value As String) As String
Dim words As Variant
words = VBA.Strings.Split(value, " ")
Dim result As String, i As Long
For i = LBound(words) To UBound(words)
result = words(i) & " " & result
Next
ReverseWords = result
End Function
Usage:
Debug.Print ReverseWords("the quick brown fox jumps over the lazy dog")
Outputs:
dog lazy the over jumps fox brown quick the
To the OP though, this isn't about inverting the words in a string at all. The solution is to parse the given string.
The first capital letter is indeed where I want to swap
So you need to find the index of the first capital letter in the input string, then extract the first & last name, trim them, then concatenate them.
This works:
Public Function ReverseFullName(ByVal value As String) As String
Dim firstCapitalIndex As Long, i As Long
For i = 1 To Len(value)
If IsCapitalLetter(Mid$(value, i, 1)) Then
firstCapitalIndex = i
Exit For
End If
Next
If i = 1 Then
'already shaped as needed
ReverseFullName = value
Exit Function
End If
Dim firstName As String
firstName = Trim$(Left$(value, firstCapitalIndex - 1))
Dim lastName As String
lastName = Trim$(Mid$(value, firstCapitalIndex))
ReverseFullName = lastName & ", " & firstName
End Function
Private Function IsCapitalLetter(ByVal value As String) As Boolean
Dim asciiCode As Integer
asciiCode = Asc(value)
IsCapitalLetter = asciiCode >= Asc("A") And asciiCode <= Asc("Z")
End Function
Usage:
Debug.Print ReverseFullName("van de Voort van Zijp")
Debug.Print ReverseFullName("de Vries")
Debug.Print ReverseFullName("Voort van Zijp, van de")
Outputs:
Voort van Zijp, van de
Vries, de
Voort van Zijp, van de