VB get data from excel - validation - vb.net

I have a code which is mainly working except I have a validation error...
My code has a search box where I put the surname in, the idea is that if the surname entered is in the excel sheet and a bunch of information is returned. This works as desired, as does my validation for no data entered in the search box.
What doesn't work is my validation for when I enter something in the search box which isn't a match (i.e. not in the excel sheet). Please see 'match validation' in the following code to see what I'm referring to do.
I just have no idea why it isn't working. I don't even get an error when I run the code and enter in wrong data, it just doesn't return an error message like it should and the form sort of freezes up (kinda like its in a non stop loop).
Any advice would be great, Thanks! Here some of the code:
'define objects
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
'Open a existing workbook and sheet in excel
oExcel = CreateObject("Excel.Application")
oBook = oExcel.Workbooks.Open(Filename:="c:\users\timothy\desktop\coding\output.xlsx")
oSheet = oBook.Worksheets(1)
Dim getSurname As String = ""
Dim getFirstname As String = ""
Dim getAge As String = ""
Dim getGender As String = ""
Dim getNum As Integer = 1
Dim getValidate As Integer = 0
While oBook.Worksheets(1).Range("A" & getNum).value <> searchInput.Text.ToUpper
getNum = getNum + 1
End While
'Length Validation (THIS WORKS)
If Len(searchInput.Text) = 0 Then
getValidate = getValidate + 1
End If
'Match validation (THIS DOES NOT WORK)
If oBook.Worksheets(1).Range("A" & getNum).value <> searchInput.Text.ToUpper Then
getValidate = getValidate + 1
End If
If getValidate = 0 Then
getSurname = oSheet.Range("A" & getNum).Value.ToString
getFirstname = oSheet.Range("B" & getNum).Value.ToString
getAge = oSheet.Range("C" & getNum).Value.ToString
getGender = oSheet.Range("D" & getNum).Value.ToString
outputData.Text = "SURNAME: " & getSurname & vbCrLf & "FIRSTNAME: " & getFirstname & vbCrLf & "AGE: " & getAge & vbCrLf & "GENDER: " & getGender & vbCrLf
Else
MsgBox("ERROR!! Please enter valid Quote Number.")
End If

This section of code
While oBook.Worksheets(1).Range("A" & getNum).value <> searchInput.Text.ToUpper
getNum = getNum + 1
End While
will continue to loop through the worksheet until it finds a match. Let's assume you get to the last row of your data with no match yet. The next "A" & getNum will be blank, which will not be a match, and so it will continue the While, until it hits your row limit and errors out. It never finds a match, so it will never hit your check.
However, I think if you put a check in there to look for those blank cells...
While oBook.Worksheets(1).Range("A" & getNum).value <> searchInput.Text.ToUpper
if oBook.Worksheets(1).Range("A" & getNum).value = "" then
exit while
else
getNum = getNum + 1
end if
End While
,then I think it will do what you are looking to do.

I think that if you are going to work on really big spread sheets, you are going to run into trouble looping. Can you not rather use Find?
See: http://www.vbforums.com/showthread.php?634644-Excel-Find-Method-in-Excel-VBA-(Any-version-of-Excel)
See Down bottom (using find as vlookup)

Related

Editing the cell value in Specialcells fails?

I have two sheets, one that information about decks played by players, who owns it, what the deck name is, and earlier names. Then another where I have match information of said player, owner and deck name.
My aim is to update match information deck names to newest. I've these two subprocedures. First finds what we need to update, then uses a filtering subprocedure to filter the match list to only have matches containing the player, owner and deck combination visible.
Then it calls the other method, where I try to update the name. It runs nicely, says happily in the debug log that it has beeen renamed from oldname to new name, but when it's finished, the value in the deck name cell remains unchanged.
What am I doing wrong?
EDIT: I tried out your script, Pefington, and amended the split of for i and for each loops. I also used the Variant approach you suggested. Now it runs again, and says it tries to update 'chulane precon to chulane', but that change is not reflected in the excel sheet.
Had to do an rather ugly way of populating the array of Variants with from the array of Strings.
I also added a rownumber to just check in debugger that it indeed goes through the row with chulane precon, and it does, but still fails to actually save the chulane into the cell. Which is the thing I need help with. :)
Sub CleanOldDeckNames()
' DISABLE EXCEL ANIMATIONS
Application.ScreenUpdating = False
Dim player As String
Dim owner As String
Dim concatenatedOldNames As String
Dim oldNamesArray() As Variant
Dim currentName As String
Dim currentOldName As String
Dim temporaryOldNameStringArray() As String
Dim j As Integer
Dim oldName As Variant
Sheets("Decklist").Select
Call dl_search_deck_hidden_reset
For i = 12 To 50
player = ActiveWorkbook.Worksheets("Decklist").range("A" & i).Value
owner = ActiveWorkbook.Worksheets("Decklist").range("B" & i).Value
currentName = ActiveWorkbook.Worksheets("Decklist").range("C" & i).Value
concatenatedOldNames = ActiveWorkbook.Worksheets("Decklist").range("D" & i).Value
If Not (StrComp(concatenatedOldNames, "") = 0) Then
temporaryOldNameStringArray = Split(concatenatedOldNames, ",")
j = 0
For Each oldNameToBeConverted In temporaryOldNameStringArray
ReDim Preserve oldNamesArray(j)
oldNamesArray(j) = CStr(oldNameToBeConverted)
j = j + 1
Next oldNameToBeConverted
For Each oldName In oldNamesArray
currentOldName = Trim(CStr(oldName))
Sheets("Game Logs").Select
ActiveWorkbook.Worksheets("Game Logs").range("E1:G1").Value = Array(player, owner, currentOldName)
Call gl_find_rename_deck
Call RenameInSpecialCells(currentOldName, currentName)
Next oldName
End If
Next
Call gl_find_rename_deck_reset
' ENABLE EXCEL ANIMATIONS
Application.ScreenUpdating = True
End Sub
Sub RenameInSpecialCells(oldName As String, currentName As String)
For Each cell In ActiveWorkbook.Worksheets("Game Logs").AutoFilter.range.SpecialCells(xlCellTypeVisible)
If (StrComp(cell, oldName) = 0) Then
Dim rownumber As Integer
rownumber = cell.row
cell = currentName
Debug.Print ("Renamed " & oldName & " to " & currentName)
End If
Next cell
End Sub
Edit to add after feedback:
Sub RenameInSpecialCells(oldName As String, currentName As String)
dim rng as range, c as range
set rng = ActiveWorkbook.Worksheets("Game Logs").AutoFilter.range.SpecialCells(xlCellTypeVisible) #.range? can't get intellisense to trigger on this one#
For Each c In rng.cells
If (StrComp(c.value, oldName) = 0) Then
c.value = currentName
Debug.Print ("Renamed " & oldName & " to " & currentName)
End If
Next
End Sub
First post here, and new at coding, but I think I see some issues and hopefully can help.
Dim oldNameS As String
Note the s, plural.
You then use:
For Each oldName In oldNamesArray
Now you are calling oldName (singular) as if it was a member of an oldNames collection, but it is not.
You could go with:
For Each oldNames in oldNamesArray
The second problem I think is that you are trying to use a for each loop on a string array. To do that, your array needs to be a variant.
So your array declaration should read:
Dim oldNamesArray() as Variant
Lastly:
Dim name As Variant
I don't see this one getting used, maybe lost in the process?
With those comments the code looks like this:
Sub CleanOldDeckNames()
' DISABLE EXCEL ANIMATIONS
Application.ScreenUpdating = False
Dim player As String
Dim owner As String
Dim oldName As String
Dim oldNamesArray() As Variant
Dim currentName As String
Dim currentOldName As String
Sheets("Decklist").Select
Call dl_search_deck_hidden_reset
For i = 12 To 50
player = ActiveWorkbook.Worksheets("Decklist").range("A" & i).Value
owner = ActiveWorkbook.Worksheets("Decklist").range("B" & i).Value
currentName = ActiveWorkbook.Worksheets("Decklist").range("C" & i).Value
oldName = ActiveWorkbook.Worksheets("Decklist").range("D" & i).Value
oldNamesArray = Split(oldName, ",")
next
For Each oldName In oldNamesArray
currentOldName = Trim(CStr(oldName)) #not sure if CStr required#
Sheets("Game Logs").Select
ActiveWorkbook.Worksheets("Game Logs").range("E1:G1").Value = Array(player, owner, currentOldName)
Call gl_find_rename_deck
Call RenameInSpecialCells(currentOldName, currentName)
Next
Call gl_find_rename_deck_reset
' ENABLE EXCEL ANIMATIONS
Application.ScreenUpdating = True
End Sub
Sub RenameInSpecialCells(oldName As String, currentName As String)
For Each cell In ActiveWorkbook.Worksheets("Game Logs").AutoFilter.range.SpecialCells(xlCellTypeVisible)
If (StrComp(cell, oldName) = 0) Then
cell = currentName
Debug.Print ("Renamed " & oldName & " to " & currentName)
End If
Next cell
End Sub
Apologies if I'm way off the mark.
Edit to add: Your for each in array loop doesn't use i, so you can run the for i loop and for each loop in sequence rather than nesting them. Code amended accordingly.
I finally managed to circumvent the saving. I could not find any reason for why I could not edit the cell via SpecialCells, so I grabbed the row number and column number and edited it directly in the sheet. Turned out that worked.
I also did not need to use Variant as suggested, this simply works.
Sub CleanOldDeckNames()
' DISABLE EXCEL ANIMATIONS
Application.ScreenUpdating = False
Dim player As String
Dim owner As String
Dim oldNames As String
Dim oldNamesArray() As String
Dim currentName As String
Dim currentOldName As String
Dim j As Integer
Sheets("Decklist").Select
Call dl_search_deck_hidden_reset
For i = 12 To 50
player = ActiveWorkbook.Worksheets("Decklist").range("A" & i).Value
owner = ActiveWorkbook.Worksheets("Decklist").range("B" & i).Value
currentName = ActiveWorkbook.Worksheets("Decklist").range("C" & i).Value
oldNames = ActiveWorkbook.Worksheets("Decklist").range("D" & i).Value
oldNamesArray = Split(oldNames, ",")
Dim name As Variant
For Each oldName In oldNamesArray
currentOldName = Trim(oldName)
Sheets("Game Logs").Select
ActiveWorkbook.Worksheets("Game Logs").range("E1:G1").Value = Array(player, owner, currentOldName)
Call gl_find_rename_deck
Call RenameInSpecialCells(currentOldName, currentName)
Next oldName
Next i
Call gl_find_rename_deck_reset
' ENABLE EXCEL ANIMATIONS
Application.ScreenUpdating = True
End Sub
Sub RenameInSpecialCells(oldName As String, currentName As String)
For Each cell In ActiveWorkbook.Worksheets("Game Logs").AutoFilter.range.SpecialCells(xlCellTypeVisible)
If (StrComp(cell, oldName) = 0) Then
Debug.Print ("Attemtping to rename: " & cell)
ActiveWorkbook.Worksheets("Game Logs").Cells(cell.row, cell.Column).Value = "Chulane"
Debug.Print ("New content: " & ActiveWorkbook.Worksheets("Game Logs").Cells(cell.row, cell.Column))
End If
Next cell
End Sub

Excel Transform Sub to Function

I am quite new in VBA and wrote a subroutine that copy-paste cells from one document into another one. Being more precise, I am working in document 1 where I have names of several product (all in column "A"). For these product, I need to look up certain variables (e.g. sales) in a second document.
The subroutine is doing the job quite nicely, but I want to use it as a funcion, i.e. I want to call the sub by typing in a cell "=functionname(productname)".
I am grateful for any helpful comments!
Best, Andreas
Sub copy_paste_data()
Dim strVerweis As String
Dim Spalte
Dim Zeile
Dim findezelle1 As Range
Dim findezelle2 As Range
Dim Variable
Dim Produkt
'Variable I need to copy from dokument 2
Variable = "frequency"
'Produkt I need to copy data from document 2
Produkt = Cells(ActiveCell.Row, 1)
'path, file and shhet of document 2
Const strPfad = "C:\Users\Desktop\test\"
Const strDatei = "Bezugsdok.xlsx"
Const strBlatt = "post_test"
'open ducument 2
Workbooks.Open strPfad & strDatei
Worksheets(strBlatt).Select
Set findezelle = ActiveSheet.Cells.Find(Variable)
Spalte = Split(findezelle.Address, "$")(1)
Set findezelle2 = ActiveSheet.Cells.Find(Produkt)
Zeile = Split(findezelle2.Address, "$")(2)
'copy cell that I need
strZelle = Spalte & Zeile 'Zelladresse
strVerweis = "'" & strPfad & "[" & strDatei & "]" & strBlatt & "'!" & strZelle
'close document 2
Workbooks(strDatei).Close savechanges:=False
With ActiveCell
.Formula = "=IF(" & strVerweis & "="""",""""," & strVerweis & ")"
.Value = .Value
End With
End Sub
Here is an example to create a function that brings just the first 3 letters of a cell:
Public Function FirstThree(Cell As Range) As String
FirstThree = Left(Cell.Text, 3)
End Function
And using this in a Excel worksheet would be like:
=FirstThree(b1)
If the sub works fine and you just want to make it easier to call you can add a hotkey to execute the Macro. In the developer tab click on Macros then Options. You can then add a shortcut key (Crtl + "the key you want" it can be a shortcut key already used like C, V, S, but you will lose those functions (Copy, Paste Save, Print)
enter image description here

Walking Through Flagged Cells Individually

I have a stretch goal for my project that goes way beyond my current ability, but I was hoping someone here could put me on the right track. I have the following code:
Public ErrorCount As Integer
Sub GeneralFormat()
ErrorCount = 0
VLookup
MacroFillAreas
color
NonZeroCompare
MustBe
MsgBox ("Number of Errors" & CStr(ErrorCount))
End Sub
I also have the following section of the code:
Sub NonZeroCompare()
Dim i As Long
For i = 5 To 1000 Step 1
If Range("AK" & i).Value = "On" Then
If Range("AL" & i).Value = 0 And Range("AM" & i).Value = 0 Then
Range("AL" & i, "AM" & i).Interior.ColorIndex = 6
ErrorCount = ErrorCount + 1
End If
ElseIf Range("BC" & i).Value = 0 And Range("BD" & i).Value = 0 Then
Range("BC" & i, "BD" & i).Interior.ColorIndex = 6
ErrorCount = ErrorCount + 1
ElseIf Range("EJ" & i).Value = "On" Then
If Range("EK" & i).Value = 0 And Range("EL" & i).Value = 0 Then
Range("EK" & i, "EL" & i).Interior.ColorIndex = 6
ErrorCount = ErrorCount + 1
End If
ElseIf Range("ES" & i).Value = 0 And Range("ET" & i).Value = 0 Then
Range("ES" & i, "ET" & i).Interior.ColorIndex = 6
ErrorCount = ErrorCount + 1
ElseIf Range("FG" & i).Value = 0 And Range("FH" & i).Value = 0 Then
Range("FG" & i, "FH" & i).Interior.ColorIndex = 6
ErrorCount = ErrorCount + 1
End If
Next i
End Sub
My desired effect is to have the user be able to jump to each cell that contributes to "ErrorCount". There are thousands of cells in my workbook to manage, so being able to jump to the error on review would be great. It would be even better if it could be done with one key on the keyboard, but a button would work too.
Any ideas on how to execute something like this? Also, difficulty level? Any resources on where to begin on this type of feature? Last question: Any native features to excel that I can code in to use that won't require hardcore coding?
Here's an approach that could work in your to handle your requirements.
First, instead of holding only a count of the number of errors, we can hold a Dictionary object that holds references to the cell locations. Using this object, we can then inspect it for a total count of errors, locations, etc.
I'm going to show one (relatively simple) implementation below. (If you're unfamiliar with Dictionary objects, do some research. Basically, it holds a unique key and a corresponding value). In my case, I chose to store the address of an error cell as the key, and I just stored a blank string as the value.
First, I wrote a function to return the dictionary object holding the errors. In the simple implementation, I had a fixed range, and I stored in the address of any cell that had text 'Abc'.
Next, I wrote a helper function that returns a count of the number of objects (this is simple enough that you don't really need a helper function, but it might simplify things if making multiple calls or if you will add more customized logic).
Finally, two subroutines accomplish the final req: traversing through the errors. The first routine 'TraverseErrorsgoes through the dictionary and "visits" each of the addresses. This then yields to aDoEventscall which allows the user to do what they need to. TheJumpAhead` routine tells the system that the user is all finished.
It is helpful to attach a keyboard shortcut to the JumpAhead method. To do so, while in the Excel workbook, press ALT + F8 to open up the macro window. Select the JumpAhead routine, then click the Options button in the dialog box. This allows you to enter a letter that when pressed along with the CTRL key, runs the macro. (I selected the letter e, so CTRL + e allows me to jump ahead once I've made the changes).
There are some challenges to consider. For example, my cell addresses do NOT have a reference sheet. Therefore, if this macro switches worksheets, you may run into some trouble.
Let me know of any questions.
Dim oDictCellsWithErrors As Object
Dim bContinue As Boolean
Private Function GetErrorsDict() As Object
Dim rData As Range
Dim rIterator As Range
'This helper function returns the dictionary object containing the errors
'If it's already been populated
'If not, it creates then returns the object
If Not oDictCellsWithErrors Is Nothing Then
Set GetErrorsDict = oDictCellsWithErrors
Exit Function
End If
'Some logic to create a dictionary of errors
'In my case, I'm adding all cells that have the text "Abc"
'Your logic should differ
Set rData = Sheet1.Range("A2:A15")
Set oDictCellsWithErrors = CreateObject("Scripting.Dictionary")
For Each rIterator In rData
If rIterator.Value = "Abc" Then
If Not oDictCellsWithErrors.exists(rIterator.Address) Then
oDictCellsWithErrors(rIterator.Address) = ""
End If
End If
Next rIterator
Set GetErrorsDict = oDictCellsWithErrors
End Function
Private Function CountErrors() As Integer
'This function returns the number of errors in the document
CountErrors = GetErrorsDict().Count
End Function
Sub TraverseErrors()
Dim oDict As Object
Dim sKey As Variant
Set oDict = GetErrorsDict()
For Each sKey In oDict.keys
bContinue = False
Sheet1.Range(sKey).Activate
Do Until bContinue
DoEvents
Loop
Next sKey
MsgBox "No more errors"
End Sub
Sub JumpAhead()
bContinue = True
End Sub

Efficiently transfer Excel formatting data to text file

Here it is, I have a huge Excel workbook with which users write pricing quotes. On save, rather than saving the huge workbook, I'm transferring the relevant data to a text file and saving that text file. It's going off without a hitch, except for the one worksheet that contains formatting. I don't want the user to lose formatting when they load the previously saved quote (from the text file), so I need to determine a way to transfer that formatting data to and from the text file. Is there a smart way to do this without writing hundreds of lines of code or using any non-native Excel feature?
Here's a sample of the code for other sheets, but it's not much help for what I'm trying to do:
Sub WriteQuote()
Dim SourceFile As String
Dim data As String
Dim ToFile As Integer
Dim sh1, sh2, sh3 As Worksheet
Set sh1 = Sheets("sheet 1")
Set sh2 = Sheets("sheet 2")
Set sh3 = Sheets("sheet 3")
SourceFile = "C:\Users\███████\Desktop\test.txt"
ToFile = FreeFile
Open SourceFile For Output As #ToFile
'PRINT DETAILS TO TXT FILE
For i = 7 To 56
If sh1.Range("B" & i).Value <> "" Then
data = sh1.Range("B" & i).Value & "__"
If sh1.Range("D" & i).Value <> "" Then
data = data & sh1.Range("D" & i).Value & "__"
Else: data = data & " __"
End If
If sh1.Range("E" & i).Value <> "" Then
data = data & "ns" & "__"
Else: data = data & " __"
End If
data = data & sh1.Range("F" & i).Value & "__"
data = data & sh1.Range("G" & i).Value & "__"
data = data & sh1.Range("J" & i).Value & "__"
data = data & sh1.Range("M" & i).Value
Else: Exit For
End If
Print #ToFile, data
Next i
Close #ToFile
End Sub
This is an example using a user type ("record") and Random access IO.
There are limitations, and I believe using Random access
would probably waste space on disk, however it is a reasonable
way to go about doing this.
In the example I suggest using a bit mask for boolean properties,
for example "Bold" (a bit mask can save space and shorten the code).
The file read/write actions are based on :
https://support.microsoft.com/en-us/kb/150700
!!! It is possible that you'll get a "bad record length" error, although
every this is fine and works the first time. There are allot of reports about this issue (google VBA bad record length). If that is the case, you might want to change the IO to Binary instead of Random (code change will be needed).
!!!!! Add a module and paste the code there, or, for the very least,
paste the record in a module (not in a sheet).
Option Explicit
' Setting up a user type ("record").
' you can add more variables, however just makes sure they are fixed
' length, for example: integer\doube\byte\... Note that if you want to
' add a string, ' make sure to give it fixed length, as shown below.
Public Type OneCellRec
' this will hold the row of the source cell
lRow As Long
' this will hold the column of the source cell
lColumn As Long
' This will hold the value of the cell.
' 12 is the maximum length you expect a cell to have-
' CHANGE it as you see fit
Value As String * 12
' This hold the number format- again, you might need to
' twik the 21 length-
NumberFormat As String * 21
' will hold design values like Bold, Italic and so on
DesignBitMask1 As Integer
' will hold whether the cells has an underline- this is not boolean,
' as there are several type of underlines available.
UnderLine As Long
FontSize As Double
End Type
' ---- RUN THIS ---
Public Sub TestFullTransferUsingRec()
Dim cellSetUp As Range
Dim cellSrc As Range
Dim cellDst As Range
Dim r As OneCellRec
Dim r2 As OneCellRec
On Error Resume Next
Kill "c:\file1.txt"
On Error GoTo 0
On Error GoTo errHandle
' For the example,
' Entering a value with some design values into a cell in the sheet.
' --------------------------------------
Set cellSetUp = ActiveSheet.Range("A1")
cellSetUp.Value = 1.5
cellSetUp.Font.Bold = True
cellSetUp.Font.Size = 15
cellSetUp.Font.UnderLine = xlUnderlineStyleSingle
cellSetUp.NumberFormat = "$#,##0.00"
' Doing it again for example purposes, in a different cell.
Set cellSetUp = ActiveSheet.Range("C5")
cellSetUp.Value = "banana"
cellSetUp.Font.Bold = True
cellSetUp.Font.Size = 15
cellSetUp.Font.UnderLine = XlUnderlineStyle.xlUnderlineStyleDouble
' ============ saving the cells to the text file =============
' open file for write
Open "c:\file1.txt" For Random As #1 Len = Len(r)
' save to a record the value and the design of the cell
Set cellSrc = ActiveSheet.Range("A1")
r = MyEncode(cellSrc)
Put #1, , r
' save to a record the value and the design of the cell
Set cellSrc = ActiveSheet.Range("C5")
r = MyEncode(cellSrc)
Put #1, , r
Close #1
' ============ loading the cells from the text file =============
Application.EnableEvents = False
' open file for read
Dim i%
Open "c:\file1.txt" For Random As #1 Len = Len(r2)
' read the file
For i = 1 To Int(LOF(1) / Len(r))
Get #1, i, r2
' destination cell- write the value and design
' --------------------------------------------
Set cellDst = Sheet2.Cells(r2.lRow, r2.lColumn)
Call MyDecode(cellDst, r2)
Next
'Close the file.
Close #1
errHandle:
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Number & " " & _
Err.Description, vbExclamation, "Error"
On Error Resume Next
Close #1
On Error GoTo 0
End If
Application.EnableEvents = True
End Sub
' Gets a single cell- extracts the info you want into a record.
Public Function MyEncode(cell As Range) As OneCellRec
Dim r As OneCellRec
Dim i%
i = 0
r.lRow = cell.row
r.lColumn = cell.column
r.Value = cell.Value
r.FontSize = cell.Font.Size
r.UnderLine = cell.Font.UnderLine
r.NumberFormat = cell.NumberFormat
' Use a bit mask to encode true\false excel properties.
' the encode is done using "Or"
If cell.Font.Bold = True Then i = i Or 1
If cell.Font.Italic = True Then i = i Or 2
'If cell. ..... .. = True Then i = i Or 4
'If cell. ..... .. = True Then i = i Or 8
'If cell. ..... .. = True Then i = i Or 16
'If cell. ..... .. = True Then i = i Or 32
'If cell. ..... .. = True Then i = i Or 64
'If cell. ..... .. = True Then i = i Or 128
'If cell. ..... .. = True Then i = i Or 256
' Remember the Integer limit. If you want more than int can handle,
' use long type for the i variable and r.DesignBitMask1 variable.
'If cell. ..... .. = True Then i = i Or ' (2^x)-
r.DesignBitMask1 = i
MyEncode = r
End Function
' Decode- write the info from a rec to a destination cell
Public Sub MyDecode(cell As Range, _
r As OneCellRec)
Dim i%
cell.Value = r.Value
i = r.DesignBitMask1
cell.Value = Trim(r.Value)
cell.Font.Size = r.FontSize
cell.Font.UnderLine = r.UnderLine
' trim is important here
cell.NumberFormat = Trim(r.NumberFormat)
' Use a bit mask to decode true\false excel properties.
' the decode is done using "And"
If i And 1 Then cell.Font.Bold = True
If i And 2 Then cell.Font.Italic = True
'If i And 4 Then ...
'If i And 8 Then ...
'...
End Sub
You could try TextToColumns. You're writing a delimiter in "__" that you could take advantage of. It also seems to keep the formatting of the cells when receiving the parsed text.
Sub ReadQuote()
SourceFile = "C:\Users\||||||\Desktop\test.txt"
Open SourceFile For Input As #8
Input #8, data
Range("M1") = data 'Temporary holder for an input line
'Range to start the parsed data "A1" in this example
Range("A1") = Range("M1").TextToColumns(, xlDelimited, , , , , , , , "__")
Close #8
End Sub

Outlook Forms: Importing / VLOOKUP Data from Excel?

I am a bit new to Outlook forms, but not to VBA overall - nor HTML/Web design of forms. However, my problem is finding a way to combine the two.
I am trying to design a form for users to fill out, and based on what they fill out in drop-down box's, it will then tell them what we want them to attach in the email. Currently we have this done in Excel, based on dropbox's it then VLOOKUPS to the 2nd Spreadsheet that contains the forms required.
Is there anyway I can bring in the Excel with the VLOOKUP behind the scenes in my VBA Outlook Form so that it can look-up what attachments we want the user to do? Otherwise, it would be a TON of SELECT CASE statements in VBA =/
This seems to the do the trick for me.
Some of it I have cobbled together from sites like this, the rest has been created by myself from scratch.
When I click my button:
An input box appears, which is the value that will be looked up in the spreadsheet.
it looks in the range (specified in the code), for a match
returns the value, two columns to the left of it.
when it finds a match it puts it in the Subject line in Outlook.
Dim jobno As String
Dim Proj As String
Sub Test()
jobno = InputBox("Job Number?", "Test")
GetNameFromXL
If jobno <> "" Then
Set myItem = Application.CreateItem(0)
If Proj <> "" Then
myItem.Subject = jobno & " - " & Proj & " - " & Format(Date, "dd.mm.yy")
Else
myItem.Subject = jobno & " - " & Format(Date, "dd.mm.yy")
End If
myItem.Display
Else
Exit Sub
End If
End Sub
Sub GetNameFromXL()
'Late binding. No reference to Excel Object required.
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Set xlApp = CreateObject("Excel.Application")
'Open the spreadsheet to get data
Set xlWB = xlApp.Workbooks.Open("X:\...\FILENAME.xlsx") ' <-- Put your file path and name here
Set xlWS = xlWB.Worksheets(1) ' <-- Looks in the 1st Worksheet
Debug.Print "-----Start of 'For Each' loop"
For Each c In xlWS.Range("A6:A100") 'Change range to value you want to 'VLookUp'
Proj = c.Offset(0, 2).Value 'This looks at the 2nd column after the range above
Debug.Print c & Proj
If jobno = c Then
Debug.Print "-----Match Found: " & jobno & " = " & Proj
GoTo lbl_Exit
Else
End If
Next c
Debug.Print "-----End of For Each loop"
MsgBox jobno & " not found in WorkBook."
'Clean up
Set xlWS = Nothing
Set xlWB = Nothing
Set c = Nothing
Proj = ""
xlApp.Quit
Set xlApp = Nothing
lbl_Exit:
Exit Sub
End Sub