I am a novice programmer and I'm building a form via VBA for excel where the user will input employee's time sheet and their initials via 16 text box's in the form. The text boxes data are stored to a string array. The code is:
Dim initials(15) As String
initials(0) = TB_Initials_1
initials(1) = TB_Initials_2
initials(2) = TB_Initials_3
...
initials(15) = TB_Initials_15
After using the find function and referencing some data from a one excel sheet, I use
ActiveCell.Offset(0, 2).Value = Join(initials, ".")
to output the following
"js.rs.............." to the active cell in a different excel sheet, (I only entered 2 of the 16 input boxes, hence there's two initials. JS.RS
The trailing .............. is what I want to remove. this will be imported into a Database later via the excel sheet.
How can I remove the xtras ".........'s at the end of the string? I have tried the "Trim()" function, but that does not work in my case. Everything i've tried online does not seem to work either or is referencing items from a work book, not a text box.
Any help is appreciated.
The entire code is below:
Option Explicit
'Variable declaration
Dim startTime(15), endTime(15), ST_Finish_Date As Date
Dim totalmin(15), Total_min, Total_Cost, Rate(15), Line_cost(15), Cost_Per_Part As String
Dim initials(15) As String
Dim i, ii As Integer
Dim Found_ini(15) As Range
Dim Found As Range 'returned value from find
Dim TBtraveller_value As String 'text box traveller value
Dim Found2 As Range 'store part code range
Dim TBDESC As Range ' Returned value from 2nd search
Dim BL_Find_Check As Boolean
Private Sub CB_Write_Click()
create_csv
End Sub
Private Sub Close_Form_Click()
Unload Traveller_Entry
End Sub
'still need to make this for every start / stop time text box.
Private Sub TB_Time_Start_1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim myvar As String
If Not Me.TB_Time_Start_1 Like "??:??" Then
MsgBox "Please use format 'HH:MM'"
Cancel = True
Exit Sub
End If
myvar = Format(Me.TB_Time_Start_1, "hh:mm")
Me.TB_Time_Start_1 = myvar
End Sub
Public Sub travellerNUM_TextBox_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Workbooks("Traveller entryxlsm.xlsm").Activate
TBtraveller_value = travellerNUM_TextBox.Value
If TBtraveller_value = "" Then
MsgBox ("Enter a Shop Traveller Number!")
Exit Sub
Else
TBtraveller_value = travellerNUM_TextBox.Value
Set Found = Sheets("woss").Range("A:A").Find(what:=TBtraveller_value, lookat:=xlWhole)
If Found Is Nothing Then
MsgBox (TBtraveller_value & " Not Found!")
Exit Sub
Else
Part_Code_BOX.Value = Found.Offset(0, 1) 'enters the info into the Part Code Box.
Set Found2 = Found.Offset(0, 1)
End If
If Part_Code_BOX = "" Then
MsgBox ("Traveller number " & TBtraveller_value & " has no part code associated with it." & vbCrLf & "Check Work Order Spread Sheet is FULLY Complete.")
BL_Find_Check = True
Exit Sub
End If
Set TBDESC = Sheets("ProductList").Range("B:B").Find(what:=Found2, lookat:=xlPart)
If TBDESC Is Nothing Then
MsgBox (" Dscription Not Found!")
Else
Desc_Box = TBDESC.Offset(0, 1) 'enters the description into the description Box.
FinishDate_Box = Found.Offset(0, 8) 'enters the finish date into the finish date Box.
Employee = Found.Offset(0, 2) 'enters the Employee name into the employee name Box.
End If
End If
End Sub
Public Sub CB_POST_Click()
On Error Resume Next
startTime(0) = TB_Time_Start_1.Value
startTime(1) = TB_Time_Start_2.Value
startTime(2) = TB_Time_Start_3.Value
startTime(3) = TB_Time_Start_4.Value
startTime(4) = TB_Time_Start_5.Value
startTime(5) = TB_Time_Start_6.Value
startTime(6) = TB_Time_Start_7.Value
startTime(7) = TB_Time_Start_8.Value
startTime(8) = TB_Time_Start_9.Value
startTime(9) = TB_Time_Start_10.Value
startTime(10) = TB_Time_Start_11.Value
startTime(11) = TB_Time_Start_12.Value
startTime(12) = TB_Time_Start_13.Value
startTime(13) = TB_Time_Start_14.Value
startTime(14) = TB_Time_Start_15.Value
startTime(15) = TB_Time_Start_16.Value
endTime(0) = TB_Time_Stop_1.Value
endTime(1) = TB_Time_Stop_2.Value
endTime(2) = TB_Time_Stop_3.Value
endTime(3) = TB_Time_Stop_4.Value
endTime(4) = TB_Time_Stop_5.Value
endTime(5) = TB_Time_Stop_6.Value
endTime(6) = TB_Time_Stop_7.Value
endTime(7) = TB_Time_Stop_8.Value
endTime(8) = TB_Time_Stop_9.Value
endTime(9) = TB_Time_Stop_10.Value
endTime(10) = TB_Time_Stop_11.Value
endTime(11) = TB_Time_Stop_12.Value
endTime(12) = TB_Time_Stop_13.Value
endTime(13) = TB_Time_Stop_14.Value
endTime(14) = TB_Time_Stop_15.Value
endTime(15) = TB_Time_Stop_16.Value
initials(0) = TB_Initials_1
initials(1) = TB_Initials_2
initials(2) = TB_Initials_3
initials(3) = TB_Initials_4
initials(4) = TB_Initials_5
initials(5) = TB_Initials_6
initials(6) = TB_Initials_7
initials(7) = TB_Initials_8
initials(8) = TB_Initials_9
initials(9) = TB_Initials_10
initials(10) = TB_Initials_11
initials(11) = TB_Initials_12
initials(12) = TB_Initials_13
initials(13) = TB_Initials_14
initials(14) = TB_Initials_15
initials(15) = TB_Initials_16
For i = LBound(initials) To UBound(initials)
Set Found_ini(i) = Sheets("rate").Range("B:B").Find(what:=initials(i), lookat:=xlWhole)
Rate(i) = Found_ini(i).Offset(0, 1) 'finds rate for given initials
totalmin(i) = DateDiff("N", startTime(i), endTime(i))
If Found_ini(i) Is Nothing Then
MsgBox (initials(i) & " Not Found! Update Employee Database.")
Exit Sub
'If IsEmpty(Found_ini(i)) = False And IsEmpty(startTime(i)) = True And IsEmpty(endTime(i)) = True Then
'MsgBox "Enter Some Initials, None Found"
Exit Sub
End If
Next
For ii = LBound(totalmin) To UBound(totalmin)
Line_cost(ii) = totalmin(ii) / 60 * Rate(ii)
Next
Total_min = Application.WorksheetFunction.Sum(totalmin)
Total_Cost = Application.WorksheetFunction.Sum(Line_cost)
Cost_Per_Part = Total_Cost / TextBOX_QTYBUILT
If Total_min = 0 Then
MsgBox (" Enter Some Time!")
ElseIf Total_min < 0 Then
MsgBox ("Time is NEGATIVE. Check Entered Times.")
End If
If BL_Find_Check = False Then
MsgBox "The number of minutes between two Times : " & Total_min & vbNewLine & "total cost: " & Total_Cost _
& vbNewLine & "cost Per Part " & Cost_Per_Part, vbInformation, "Minutes Between Two Times"
Sheets("test").Select
Range("A1048576").Select
ActiveCell.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0).Value = FinishDate_Box 'Traveller finish Date
ActiveCell.Offset(0, 1).Value = TBtraveller_value 'Traveller Number
ActiveCell.Offset(0, 2).Value = Join(initials, ".") 'Traveller Employee Given to
ActiveCell.Offset(0, 3).Value = Part_Code_BOX.Value ' part number
ActiveCell.Offset(0, 4).Value = Total_Cost ' traveller total cost
ActiveCell.Offset(0, 5).Value = Cost_Per_Part 'Traveller cost per part
End If
End Sub
Sub create_csv()
Dim FileName As String
Dim PathName As String
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("test")
FileName = "CSV_Output_R1.csv"
PathName = Application.ActiveWorkbook.Path
ws.Copy
ActiveWorkbook.SaveAs FileName:=PathName & "\" & FileName, _
FileFormat:=xlCSV, CreateBackup:=False
End Sub
Thank you,
You can use WorksheetFunction.TextJoin() in Excel2019+ in one string:
ActiveCell.Offset(0, 2).Value = WorksheetFunction.TextJoin(".", True, initials)
A small example for comparison:
Sub test1()
Dim arr(1 To 15)
For i = 1 To 15
arr(i) = IIf(Rnd() > 0.7, "TXT", "")
Next
Debug.Print "With Join(): " & Join(arr, ".")
Debug.Print "With TextJoin(): " & WorksheetFunction.TextJoin(".", True, arr)
End Sub
Output
With Join(): ..TXT........TXT..TXT..
With TextJoin(): TXT.TXT.TXT
Here is a function that I just made to trim empty elements off the end of your array:
Function TrimArray(ByRef StringArray() As String) As String()
'This function removes trailing empty elements from arrays
'Searching from the last element backwards until a non-blank is found
Dim i As Long
For i = UBound(StringArray) To LBound(StringArray) Step -1
If StringArray(i) <> "" Then Exit For
Next i
If i < LBound(StringArray) Then i = LBound(StringArray)
'Creating an array with the correct size to hold the non-blank elements
Dim OutArr() As String
OutArr = StringArray
ReDim Preserve OutArr(LBound(StringArray) To i)
TrimArray = OutArr
End Function
You would use it like so:
Dim Output() As String
Output = TrimArray(initials)
MsgBox Join(Output, ".") & "."
You could build it like this instead of using Join():
ActiveCell.Offset(0, 2).Value = initials(0)
For Counter = 1 To 15
If initials(Counter) <> "" Then
ActiveCell.Offset(0, 2).Value = ActiveCell.Offset(0, 2).Value + "." + initials(Counter)
End If
Next Counter
Related
I'm certain I am overlooking something simple but I just can't figure it this morning. I am attempting to simulate a XLookup for users with VBA code. Folks I work with have a range of excel skills and some just have a really hard time with this formula.
My code prompts the users to define all relevant ranges but when the lookup itself is returning Error 9.
Sub Lookup()
Dim invRange, lkRange, rtnRange, outRange As Range
Dim strInput, invPrompt, invTitle, lkPrompt, lkTitle, rtnPrompt, rtnTitle, outPrompt, outTitle As String
Dim invArray, lkArray, rtnArray, outArray As Variant
Dim x, j, i, k As Integer
Dim txt As String
ReDim invRange(1 To 1, 1 To 1)
invPrompt = "Select the Invoices you wish to look up."
invTitle = "Select Lookup Value"
lkPrompt = "Select the column where you wish to lookup the Invoices."
lkTitle = "Select Lookup Range"
rtnPrompt = "Select the column where you wish to return data from."
rtnTitle = "Select Return Range"
outPrompt = "Select the column where you wish to output the data."
outTitle = "Select Output Range"
On Error Resume Next
' Invoice Range Selection Input Box
Set invRange = Application.InputBox( _
Prompt:=invPrompt, _
Title:=invTitle, _
Default:=Selection.Address, _
Type:=8) 'Range selection
If invRange Is Nothing Then Exit Sub
' Turns Range into Array or Exits sub if no range was selected
invArray = Application.Transpose(invRange.Value)
If IsArray(invArray) = False Then
invArray = Array(invArray)
End If
For x = 0 To UBound(invArray)
invArray(x) = Replace(invArray(x), Chr(160), " ")
invArray(x) = RTrim(invArray(x))
Next
' Lookup Range Selection Input Box
Set lkRange = Application.InputBox( _
Prompt:=lkPrompt, _
Title:=lkTitle, _
Default:=Selection.Address, _
Type:=8) 'Range selection
If lkRange Is Nothing Then Exit Sub
' Turns Range into Array or Exits sub if no range was selected
lkArray = Application.Transpose(lkRange.Value)
If IsArray(lkArray) = False Then
lkArray = Array(lkArray)
End If
For j = 0 To UBound(lkArray)
lkArray(j) = Replace(lkArray(j), Chr(160), " ")
lkArray(j) = RTrim(lkArray(j))
Next
' Return Range Selection Input Box
Set rtnRange = Application.InputBox( _
Prompt:=rtnPrompt, _
Title:=rtnTitle, _
Default:=Selection.Address, _
Type:=8) 'Range selection
If rtnRange Is Nothing Then Exit Sub
' Turns Range into Array or Exits sub if no range was selected
rtnArray = Application.Transpose(rtnRange.Value)
If IsArray(rtnArray) = False Then
rtnArray = Array(rtnArray)
End If
For i = 0 To UBound(rtnArray)
rtnArray(i) = Replace(rtnArray(i), Chr(160), " ")
rtnArray(i) = RTrim(rtnArray(i))
Next
' Output Range Selection Input Box
Set outRange = Application.InputBox( _
Prompt:=outPrompt, _
Title:=outTitle, _
Default:=Selection.Address, _
Type:=8) 'Range selection
If outRange Is Nothing Then Exit Sub
' Turns Range into Array or Exits sub if no range was selected
outArray = Application.Transpose(outRange.Value)
If IsArray(outArray) = False Then
outArray = Array(outArray)
End If
For k = 0 To UBound(outArray)
outArray(k) = Replace(outArray(k), Chr(160), " ")
outArray(k) = RTrim(outArray(k))
Next
On Error GoTo 0
'Lookup each item from LookupValue array
For i = 1 To UBound(invArray)
For j = 1 To UBound(lkArray)
If invArray(i, 1) = lkArray(j, 1) Then
outArray(i, 1) = rtnArray(j, 1)
Exit For
End If
Next j
Next i
outArray.Resize(UBound(outArray, 1), 1).Value = outArray
End Sub
I am trying to work through a code that utilizes a system to check two different worksheets by using a for loop and highlight the differences/edits made in the second sheet ("Version 2") onto the first sheet ("Original"). I have a feeling that I need to utilize an array but I'm not advanced enough where I know how to store the values and then later write them onto another sheet (down below).
I've gotten the code so that it highlights all the relevant cells, but now I'm trying to output it into a report (on another sheet called 'Logged Changes') which will summarize all the cell addresses where edits were made. Please forgive all the variables as this is from an old code set where variables are not explicitly defined:
Private Sub CompareBasic()
Dim actSheet As Range
Dim k As Integer
Dim o As Long
Dim p As Long
Dim i As Integer
Dim change As Integer
o = Worksheets("Original").Cells(2, Columns.Count).End(xlToLeft).Column
p = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
change = 0
Sheets("Original").Select
For i = 2 To p
For k = 1 To o
If IsNumeric(Worksheets("Original").Cells(i, k).Value) = True Then
If Worksheets("Original").Cells(i, k).Value <> Worksheets("Version 2").Cells(i, k).Value Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
Else
If StrComp(Worksheets("Original").Cells(i, k), Worksheets("Version 2").Cells(i, k), vbBinaryCompare) <> 0 Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
End If
Next k
Next i
Unload Me
MsgBox "Number of cells edited counted: " & change, vbOKOnly + vbExclamation, "Summary"
b = Empty
answer = MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion)
If answer = vbYes Then
If Sheet_Exists("Logged Changes") = False Then
Sheet_Name = "Logged Changes"
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
End If
Worksheets("Logged Changes").Range("A1") = "Edited Requirements"
Else
Unload Me
End If
End Sub
I have tried fiddling around with the code, but didn't want to clog it up with any unnecessary/broken lines. Any help would be greatly appreciated!
Try this:
Option Explicit
Private Sub CompareBasic()
Const SHT_REPORT As String = "Logged Changes"
Dim actSheet As Range
Dim c As Integer
Dim o As Long
Dim p As Long
Dim r As Long
Dim change As Long, wsOrig As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Dim dataOrig, dataNew, rngData As Range, v1, v2, bDiff As Boolean
Dim arrUpdates
Set wsOrig = Worksheets("Original")
Set wsNew = Worksheets("Version 2")
o = wsOrig.Cells(2, Columns.Count).End(xlToLeft).Column
p = wsOrig.Range("A" & Rows.Count).End(xlUp).Row
Set rngData = wsOrig.Range("A2", wsOrig.Cells(p, o))
dataOrig = rngData.Value 'get an array of data
dataNew = wsNew.Range(rngData.Address).Value 'array of new data
ReDim arrUpdates(1 To rngData.Cells.Count, 1 To 3) 'for change info
change = 0
For r = 1 To UBound(dataOrig, 1)
For c = 1 To UBound(dataOrig, 2)
v1 = dataOrig(r, c)
v2 = dataNew(r, c)
If Len(v1) > 0 Or Len(v2) > 0 Then
If IsNumeric(v1) Then
bDiff = v1 <> v2
Else
bDiff = StrComp(v1, v2, vbBinaryCompare) <> 0
End If
End If
'any difference?
If bDiff Then
change = change + 1
With rngData.Cells(r, c)
arrUpdates(change, 1) = .Address
.Interior.ColorIndex = 37
End With
arrUpdates(change, 2) = v1
arrUpdates(change, 3) = v2
End If
Next c
Next r
If MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion) = vbYes Then
With GetSheet(SHT_REPORT, ThisWorkbook)
.UsedRange.ClearContents
.Range("A1") = "Edited Requirements"
.Range("A3").Resize(1, 3).Value = Array("Address", wsOrig.Name, wsNew.Name)
.Range("A4").Resize(change, 3).Value = arrUpdates
End With
Else
'Unload Me
End If
End Sub
'return as sheet from wb by name (and create it if it doesn't exist)
Function GetSheet(wsName, wb As Workbook) As Worksheet
Dim rv As Worksheet
On Error Resume Next
Set rv = wb.Worksheets(wsName)
On Error GoTo 0
If rv Is Nothing Then
Set rv = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
rv.Name = "Logged Changes"
End If
Set GetSheet = rv
End Function
Sheet Differences
Option Explicit
Sub logChanges()
Const ws1Name As String = "Original"
Const ws2Name As String = "Version 2"
Const wsResult As String = "Logged Changes"
Const FirstRow As Long = 2
Const FirstColumn As Long = 1
Const LastRowColumn As Long = 1
Const LastColumnRow As Long = 2
Const ResultFirstCell As String = "A2"
Dim Headers As Variant
Headers = Array("Id", "Address", "Original", "Version 2")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(ws1Name)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
Dim LastColumn As Long
LastColumn = ws.Cells(LastColumnRow, ws.Columns.Count) _
.End(xlToLeft).Column
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
ws.Cells(LastRow, LastColumn))
Dim Data1 As Variant: Data1 = rng.Value
Set ws = wb.Worksheets(ws2Name)
Dim Data2 As Variant: Data2 = ws.Range(rng.Address).Value
Dim Result() As Variant
Dim i As Long, j As Long, k As Long
For i = 1 To UBound(Data1)
For j = 1 To UBound(Data1, 2)
If Data1(i, j) <> Data2(i, j) Then GoSub writeResult
Next j
Next i
If k > 0 Then
transpose2D Result
On Error GoTo MissingResultSheet
Set ws = wb.Worksheets(wsResult)
On Error GoTo 0
ws.Range(ws.Range(ResultFirstCell), _
ws.Cells(ws.Rows.Count, ws.Columns.Count)).Clear
ws.Range(ResultFirstCell).Resize(k, UBound(Result, 2)).Value = Result
MsgBox "Found '" & k & "' difference(s) in range '" _
& rng.Address(False, False) & "'.", vbInformation
Else
MsgBox "Found no differences in range '" _
& rng.Address(False, False) & "'.", vbExclamation
End If
Exit Sub
writeResult:
k = k + 1
ReDim Preserve Result(1 To 4, 1 To k)
Result(1, k) = k
Result(2, k) = getAddress(i + FirstRow - 1, j + FirstColumn - 1)
Result(3, k) = Data1(i, j)
Result(4, k) = Data2(i, j)
Return
MissingResultSheet:
If Err.Number = 9 Then
wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
With ActiveSheet
.Name = wsResult
If .Range(ResultFirstCell).Row > 1 Then
.Range(ResultFirstCell).Offset(-1) _
.Resize(, UBound(Headers) + 1).Value = Headers
End If
End With
Resume ' i.e. the code continues with Set ws = wb.Worksheets(wsResult)
Else
'?
Exit Sub
End If
End Sub
Function getAddress(aRow As Long, aColumn As Long) As String
getAddress = ActiveSheet.Cells(aRow, aColumn).Address(False, False)
End Function
Sub transpose2D(ByRef Data As Variant)
Dim i As Long, j As Long
Dim Result As Variant
ReDim Result(LBound(Data, 2) To UBound(Data, 2), _
LBound(Data) To UBound(Data))
For i = LBound(Data) To UBound(Data)
For j = LBound(Data, 2) To UBound(Data, 2)
Result(j, i) = Data(i, j)
Next j
Next i
Data = Result
End Sub
This solution for converting a column number to a string without using objects Function to convert column number to letter? could be used to write a descent getAddress function.
I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter
I am working on a project, which takes a checksheet that the user creates and fills out
and, when the user runs a macro, creates a new workbook that extrapolates and expands the checksheet data, as shown here
What it does is it goes through each of those number labor codes, and runs down the checksheet for all the applicable items, addending them to the list.
Now...I have this working fine, and run through the basic testing. I save the checksheet as an array and pass it through to the new workbook, filtering and creating the new workbook line-by-line.
I just can't help but think that there's a much easier way to do this, as the way I'm doing it now just doesn't seem to be the simplest and most stable way.
I'm open to sharing my code I have so far, but was wondering if you were given this senario, how you would approach it.
Here is the link to my file: https://www.dropbox.com/s/2gobdx1rcabquew/Checksheet_Template_R3.0%20-%20StkOvrflw.xls
Main module, which checks for errors and corrects formatting:
Option Explicit
Public FamilyName As String
Public ModelName As String
Public TaskArray() As Variant
Public TaskArrayRowCount As Integer
Public TaskArrayColCount As Integer
Sub CreateTemplate()
Application.EnableEvents = False
Application.ScreenUpdating = False
'Main SubModule. Runs Formatting and Template Generation
Dim thisWB As Workbook
Dim TaskArray() As Variant
Dim i As Range
Dim MajMinYesNo As Boolean
Dim OPOYesNo As Boolean
If MsgBox("Are you ready to generate the Template?", vbYesNo, "Ready?") = vbNo Then
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
MajMinYesNo = False
OPOYesNo = False
Set thisWB = ActiveWorkbook
FamilyName = thisWB.Names("Family_Name").RefersToRange
ModelName = thisWB.Names("Model_No").RefersToRange
Call CreateArray(thisWB)
'Scans Form_Type Column for "R", "S", or "A-E"
For Each i In Range("CS_FormType")
If i Like "[RS]" Then
MajMinYesNo = True
ElseIf i Like "[A-E]" Then
OPOYesNo = True
End If
Next
'Generates Templates As Needed
If MajMinYesNo Then
If MsgBox("Generate Major/Minor Template?", vbYesNo) = vbYes Then
Call MajorMinor_Generate.GenerateMajorMinor(thisWB)
End If
End If
If OPOYesNo Then
If MsgBox("Generate OPO Template?", vbYesNo) = vbYes Then
Call OPO_Generate.GenerateOPO(thisWB)
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("DONE!")
End Sub
Sub CreateArray(thisWB As Workbook)
'Checks formatting and creates array TaskArray() with all the checksheet data
With thisWB.Sheets(1)
'Confirms equal number of rows in columns "CS_TaskNo", "CS_FormType", and "CS_Task"
If (Not Range("CS_TaskNo").Rows.count = Range("CS_FormType").Rows.count) _
Or (Not Range("CS_TaskNo").Rows.count = Range("CS_Task").Rows.count) Then
MsgBox ("Task_No, Form_Type, and Task_Desc row count does not match. Please fix and try again")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
Call FormatCheck
Application.Union(Range("CS_Heading"), Range("CS_TaskNo"), Range("CS_FormType"), Range("CS_Task"), Range("CS_LaborCodes"), Range("CS_Checks")).Name = "TaskArray"
TaskArrayRowCount = Range("TaskArray").Rows.count
TaskArrayColCount = Range("TaskArray").Columns.count
ReDim TaskArray(TaskArrayRowCount, TaskArrayColCount)
TaskArray = Range("TaskArray").Value
End With
End Sub
Sub FormatCheck()
'Checks for valid labor codes and Form Types
If (Not CheckFormType()) Or (Not CheckLC()) Then
MsgBox ("Errors found, please check red-highlighted cells")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
End Sub
Function CheckFormType()
'Returns False if there's a bad Form_Type entry in range "CS_FormType", True if all OK
Dim i As Range
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_FormType")
Trim (UCase(i.Value))
If Not (i Like "[ABCDEFRS]") Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Next
CheckFormType = ReturnVal
End Function
Function CheckLC()
'Returns False if there's a bad error code, True if all OK _
Formats labor code ranges to add spaces as needed and checks _
labor codes for proper format (###X or ##X). Skips any labor _
codes starting with "28X"
Dim LaborCode As String
Dim LaborCodeLength As Integer
Dim i As Range
Dim j As Integer
Dim LCCell As Range
Dim LCArray() As String
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_LaborCodes")
Trim (UCase(i.Value))
LaborCode = i.Value
If Not Left(LaborCode, 3) Like "28?" Then
LaborCodeLength = Len(LaborCode)
'If string LaborCode is > 4, safe to assume it is a range of labor codes 123A-123F
Select Case LaborCodeLength
Case Is > 4
'Formats Labor Code Range String by adding spaces if necessary (i.e. 123A-123F to 123A - 123F)
For j = 2 To LaborCodeLength Step 1
If (IsNumeric(Mid(LaborCode, j, 1))) And Not IsNumeric(Mid(LaborCode, j + 1, 1)) And Not (Mid(LaborCode, j + 2, 1) = " ") Then
LaborCode = Left(LaborCode, j + 1) & " " & Mid(LaborCode, j + 2)
ElseIf IsNumeric(Mid(LaborCode, j, 1)) And Not (Mid(LaborCode, j - 1, 1) = " ") And Not IsNumeric(Mid(LaborCode, j - 1, 1)) Then
LaborCode = Left(LaborCode, j - 1) & " " & Mid(LaborCode, j)
End If
Next
i = LaborCode
LCArray = Split(LaborCode, " ")
'confirms the labor codes are valid
If (Not IsLaborCode(LCArray(0))) Or (Not IsLaborCode(LCArray(2))) Or (Not IsLaborCodeRange(LCArray(0), LCArray(2))) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case 0 To 4
If Not (IsLaborCode(LaborCode)) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case Else
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End Select
End If
Next
CheckLC = ReturnVal
End Function
Function IsLaborCode(LC As String) As Boolean
'returns True if Labor Code is valid, False if invalid _
Labor Code is valid if it is 2 or 3 numbers followed by a letter _
labor code format : ###X or ##X
If LC Like "###[A-Z]" Or LC Like "##[A-Z]" Then
IsLaborCode = True
Else
IsLaborCode = False
End If
End Function
Function IsLaborCodeRange(LCOne As String, LCTwo As String) As Boolean
'returns True if the LC range is valid, False if invalid. _
checks the numerical values to make sure they match and _
makes sure the letters are ascending
If (StrComp(Left(LCOne, Len(LCOne) - 1), Left(LCTwo, Len(LCTwo) - 1)) = 0) And LCOne < LCTwo Then
IsLaborCodeRange = True
Else
IsLaborCodeRange = False
End If
End Function
And here is the other module which actually takes the array and creates the new workbook:
Sub GenerateMajorMinor(thisWB As Workbook)
Dim newWB As Workbook
Dim MajMinArray() As Variant
Set newWB = Workbooks.Add
With newWB
Call FormatWorkbook
Call CreateMajMinArray(newWB, MajMinArray)
Call PopulateItemMaster(MajMinArray)
Call PopulateLaborLink(MajMinArray)
Call SaveFile(newWB, thisWB)
End With
End Sub
Sub SaveFile(newWB As Workbook, thisWB As Workbook)
'saves new workbook into the same file path as the checksheet
Dim i As Integer
Dim FileSavePath As String
Dim FamNameSave As String
FamNameSave = Replace(FamilyName, "/", "_")
i = 1
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + ".xls"
a: If Dir(FileSavePath) <> "" Then
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + "(" + CStr(i) + ").xls"
i = i + 1
GoTo a:
End If
newWB.SaveAs FileSavePath, FileFormat:=56
End Sub
Sub FormatWorkbook()
'Names and formats sheets
Sheets(1).Name = "Item_Master"
Sheets(2).Name = "Labor_Link"
With Sheets(1)
.Range("A1") = "Company_No"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Record_Status"
.Range("E1") = "Task_Desc"
.Range("F1") = "Task_No"
.Range("G1") = "Task_Seq"
.Range("H1") = "Is_Parametric"
End With
With Sheets(2)
.Range("A1") = "Company_Name"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Labor_Code"
.Range("E1") = "Print_Control"
.Range("F1") = "Record_Status"
.Range("G1") = "Task_No"
End With
End Sub
Sub CreateMajMinArray(newWB As Workbook, MajMinArray As Variant)
'creates array, removing any OPO/BTS labor codes
With Sheets(3)
Application.EnableEvents = True
Application.ScreenUpdating = True
Dim rng As Range
Set rng = .Range(.Range("A1"), .Cells(TaskArrayRowCount, TaskArrayColCount))
rng = TaskArray
For i = 1 To .Range("A1").End(xlDown).Row Step 1
If .Cells(i, 2) Like "[A-E]" Then
.Rows(i).Delete
i = i - 1
End If
Next
For i = 1 To .Range("A1").End(xlToRight).Column Step 1
If Left(.Cells(1, i), 3) Like "28E" Then
.Columns(i).Delete
i = i - 1
End If
Next
ReDim MajMinArray(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)
MajMinArray = .Range(.Range("A1"), .Cells(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)).Value
.Cells.Clear
End With
End Sub
Sub PopulateItemMaster(MajMinArray As Variant)
With Sheets(1)
'Populates "Item_Master" Sheet
For i = 2 To UBound(MajMinArray) Step 1
.Cells(i, 2) = FamilyName
.Cells(i, 3) = MajMinArray(i, 2)
.Cells(i, 4) = "1"
.Cells(i, 5) = MajMinArray(i, 3)
.Cells(i, 6) = MajMinArray(i, 1)
.Cells(i, 7) = MajMinArray(i, 1)
Next
End With
End Sub
Sub PopulateLaborLink(MajMinArray As Variant)
Dim i As Integer
Dim LaborCode As String
Dim RowCount As Long
Dim LCArray() As String
Dim LastLetter As String
Dim LastFormType As String
'Initializes RowCount and PrintControl
RowCount = 2
PrintControl = 10
With Sheets(2)
For i = 4 To UBound(MajMinArray, 2) Step 1
LaborCode = Trim(MajMinArray(1, i))
'If Labor Code String length is > 4, safe to assume that it is a range of labor codes
Select Case Len(LaborCode)
Case Is > 4
LCArray = Split(LaborCode, " ")
'checks to see if LCArray(0) and LCArray(2) has values
If LCArray(0) = "" Or LCArray(2) = "" Then
MsgBox ("Error with Labor Code range. Please check and re-run")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
LastLetter = Chr(Asc(Right$(LCArray(2), 1)) + 1)
LCArray(2) = Replace(LCArray(2), Right$(LCArray(2), 1), LastLetter)
Do
Call PrintLaborLinkLines(MajMinArray, LCArray(0), RowCount, i)
LastLetter = Chr(Asc(Right$(LCArray(0), 1)) + 1)
LCArray(0) = Replace(LCArray(0), Right$(LCArray(0), 1), LastLetter)
Loop Until LCArray(0) = LCArray(2)
Erase LCArray()
Case Is <= 4
Call PrintLaborLinkLines(MajMinArray, LaborCode, RowCount, i)
End Select
Next
End With
End Sub
Sub PrintLaborLinkLines(MajMinArray As Variant, LaborCode As String, RowCount As Long, i As Integer)
Dim PrintControl As Long
PrintControl = 10
With Sheets(2)
For x = 2 To UBound(MajMinArray) Step 1
If UCase(MajMinArray(x, i)) = "Y" Then
If LastFormType <> MajMinArray(x, 2) Then
PrintControl = 10
End If
.Cells(RowCount, 2) = FamilyName
.Cells(RowCount, 3) = MajMinArray(x, 2)
.Cells(RowCount, 4) = LaborCode
.Cells(RowCount, 5) = PrintControl
.Cells(RowCount, 6) = "1"
.Cells(RowCount, 7) = MajMinArray(x, 1)
RowCount = RowCount + 1
PrintControl = PrintControl + 10
LastFormType = MajMinArray(x, 2)
End If
Next
End With
End Sub
If restructuring the order of the data on the new sheet is possible it seems as though you could copy only visible cells and then write a simple loop to bring in any data that is not explicit (ie Labor Code).
For some reason my code compiles, but it won't insert anything into the sheet ArrayData for the Chart Generation....This section I speak of is towards the end of the code with a For/If loop...
Since there are many values and excel's series input has a character limit of 255, I am putting these values in an unused sheet....but they aren't showing up when the code writes...
Private Sub cmdGraphs_Click()
'*************************************************************************************'
'The Code below is only for the Graphing Parameter inputs '
'*************************************************************************************'
Static Counter As Integer
'Variable to keep track of the amount of graphs generated
Dim graphName As String
graphName = form2.textName.Text
Dim slot As Integer, sheet As String
'Verify that an item was selected
If listSlot.ListIndex = -1 Then
'If ListIndex is -1, nothing selected
MsgBox "Select a slot number!"
Else
'If ListIndex not -1 inform user what was selected
MsgBox "You selected: " & listSlot.Value
'As a reference to the selected value
slot = listSlot.Value
End If
If listSheet.ListIndex = -1 Then
MsgBox "Select a Sheet"
Else
MsgBox "You selected: " & listSheet.Value
sheet = listSheet.Value
End If
'*************************************************************************************'
'The Code below is for setting up the table where the first graphs will be '
'*************************************************************************************'
'Selects sheet for graphic puposes
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(2, 1).Select
'Begin Plotting Table Data
Dim rang As Range
Set rang = Range("A3")
If Counter <> 0 Then
rang.Offset(Counter, 0) = graphName
rang.Offset(Counter, 1).Value = sheet
rang.Offset(Counter, 2).Value = slot
rang.Offset(Counter, 3).Value = "Formula to be written"
rang.Offset(Counter, 4).Value = "Formula to be written"
rang.Offset(Counter, 5).Value = "Formula to be written"
Else
'Table Setup
Sheets("Sheet2").Cells(1, 1).Value = "Current Sheet: " & ActiveSheet.Name
Sheets("Sheet2").Range("A1:F2").Interior.ColorIndex = 15
Sheets("Sheet2").Cells(1, 1).Font.Name = "Lucida Calligraphy"
Sheets("Sheet2").Cells(1, 1).Font.Size = 16
Sheets("Sheet2").Range("A1:F2").Font.Italic = True
Sheets("Sheet2").Cells(2, 1).Value = "Graph Name"
Sheets("Sheet2").Cells(2, 2).Value = "Data Sheet: " & sheet
Sheets("Sheet2").Cells(2, 3).Value = "Slot No. "
Sheets("Sheet2").Cells(2, 4).Value = "TW AVG "
Sheets("Sheet2").Cells(2, 5).Value = "Sigma %"
Sheets("Sheet2").Cells(2, 6).Value = "Angle"
Sheets("Sheet2").Columns("A:G").AutoFit
rang.Value = graphName
rang.Offset(0, 1).Value = sheet
rang.Offset(0, 2).Value = slot
rang.Offset(0, 3).Value = "Formula to be written"
rang.Offset(0, 4).Value = "Formula to be written"
rang.Offset(0, 5).Value = "Formula to be written"
'Adds a sheet for Array sorting due to 255 character limit
Worksheets.Add(After:=Worksheets(1)).Name = "Array Data" & Counter
End If
Sheets("Sheet2").Columns("A:G").AutoFit
'*************************************************************************************'
'Search Algorithm for user defined Slot Number '
'*************************************************************************************'
Dim slotRang As Range, slotArr() As Variant, i As Long
Set slotRang = Range("P2", Range("P2").End(xlDown))
slotArr = slotRang.Value
'This section is to to search for the value the user selected which is slot and only
'store the rows in this case into arrays and then to be parsed into another worksheet for
'another code to be added to generate a graph
For i = 2 To UBound(slotArr, 1)
If slotArr(i, 1) = slot Then
MsgBox ("In the Array Loop")
Dim xRang As Range, xArr2() As Variant
Set xRang = slotRang.Offset(0, 4)
xArr2 = xRang.Value
Dim arrDatax As Range
Dim arrDatay As Range
Set arrDatax = Worksheets("ArrayData" & Count).Range("A1", Range("A1").End(xlDown))
arrDatax.Value = Application.Transpose(arrDatax(i, 1))
Dim yRang As Range, yArr() As Variant
Set yRang = slotRang.Offset(0, 5)
yArr = yRang.Value
Set arrDatay = Worksheets("ArrayData" & Count).Range("B1", Range("B1").End(xlDown))
arrDatay.Value = Application.Transpose(arrDatay(i, 1))
End If
Next
textName.Value = ""
Counter = Counter + 1
End Sub
Assuming your code is placed in ThisWorkBook module or Module, NOT sheet Module
The problem of your posted code:
Case Counter = 0
You will run to the code part:
Worksheets.Add(After:=Worksheets(1)).Name = "Array Data" & Counter
Which is creating a new worksheet
this worksheet becomes the ActiveSheet
So, you line:
Set slotRang = Range("P2", Range("P2").End(xlDown))
The P Range will be referring to new sheet's range P, which is empty --> no result
If your code is in Sheet Module
You should always add Me in front of the range to make it clear
Which worksheet the range belongs to.
E.g. Me.Range("P1:P5")
instead of Range("P1:P5")
And you should use debug mode to identify which line the problem lay in, and highlight that line of code.