Look for some help on deleting any existing exceptions in the calendar before I add the new ones from my spreadsheet. I'm not sure what else they want me to write.
Sub LoadHolidaysFromExcel()
Dim objXL As Object
Dim objWB As Object
Dim objWS As Object
Set objXL = CreateObject("Excel.Application")
MyFile = objXL.GetOpenFilename
Set objWB = objXL.Workbooks.Open(MyFile)
Set objWS = objWB.Worksheets(1)
'this next line is commented out for running the code, makes it visable
'objXL.Visible = True
objWS.Range("A1").Select
LR = objXL.ActiveCell.CurrentRegion.Rows.Count
'Call deleteCalendarExceptions
For x = 1 To LR - 1
MyName = objXL.ActiveCell.Offset(x, 0).Value
MyStart = objXL.ActiveCell.Offset(x, 1).Value
MyFinish = objXL.ActiveCell.Offset(x, 2).Value
MyCalendar = objXL.ActiveCell.Offset(x, 3).Value
ActiveProject.BaseCalendars(MyCalendar).Exceptions.Add Type:=1, Start:=MyStart, Finish:=MyFinish, name:=MyName
Next x
objXL.Workbooks.Close
MsgBox "all done!"
End Sub
I've tried the following but it fails
For Each x In ActiveProject.BaseCalendars(MyCalendar).Exceptions
x.Delete
Here is the script to deleteCalendarExceptions
Sub deleteCalendarExceptions()
Dim e As Exception
Dim CalNam As String
CalNam = ActiveProject.Calendar.name
For Each e In ActiveProject.BaseCalendars(CalNam).Exceptions
e.Delete
Next e
End Sub
This works for me:
Public Sub DeleteExceptions(cal As MSProject.Calendar)
Dim e As MSProject.Exception
For Each e In cal.Exceptions
e.Delete
Next e
End Sub
Related
is there I way for searching a value on the next sheet (ActiveSheet.Next.Activate) without jumping on to it?
Here the whole Code:
the problem is, it jumps to the next sheet even if there is no searched value.
Dim ws As Worksheet
Dim Loc As Range
Dim StrVal As String
Dim StrRep As String
Dim i As Integer
Private Sub CommandButton1_Click()
i = 1
Call Replacing
End Sub
Private Sub CommandButton2_Click()
i = 2
Call Replacing
End Sub
Public Sub Replacing()
StrVal = Userform1.Textbox1.Text
StrRep = Me.Textbox1.Text
if Trim(StrVal) = "" Then Exit Sub
Dim fstAddress As String
Dim nxtAddress As String
For Each ws In ThisWorkbook.Worksheets
With ws
Set Loc = .Cells.Find(what:=StrVal)
fstAddress = Loc.Address
If Not Loc Is Nothing Then
If Not StrRep = "" And i = 1 Then
Loc.Value = StrRep
Set Loc = .Cells.FindNext(Loc)
ElseIf i = 2 Then Set Loc = Range(ActiveCell.Address)
Set Loc = .Cells.FindNext(Loc)
nxtAddress = Loc.Address
If Loc.Address = fstAddress Then
ActiveSheet.Next.Activate '****Here it should jump only if found something on the next sheet****
GoTo repeat
nxtAddress = Loc.Address
End If
If Not Loc Is Nothing Then Application.Goto ws.Range(nxtAddress), False
End If
i = 0
End If
End With
Set Loc = Nothing
repeat:
Next ws
End Sub
the variable "i" which switches between the values 0, 1 and 2 is bound to two buttons. these buttons are "Replace" and "Skip (to next found value)".
This code asks on each occurrence of StrVal whether you want to replace the value or skip it.
I found a problem checking if Found_Address = First_Found_Address:
If you've replaced the value in in First_Found_Address it won't find that address again and miss the starting point in the loop.
Also the original source of the code stops at the last value using Loop While Not c Is Nothing And c.Address <> firstAddress. The problem here is that if the value in c is being changed eventually c will be Nothing but it will still try and check the address of c - causing an error (Range Find Method).
My solution to this is to build up a string of visited addresses on the sheet and checking if the current address has already been visited using INSTR.
I've included the code for calling from a button click or from within another procedure.
Private Sub CommandButton1_Click()
FindReplace Userform1.Textbox1.Text, 1
End Sub
Private Sub CommandButton2_Click()
FindReplace Userform1.Textbox1.Text, 1, Me.Textbox1.Text
End Sub
Sub Test()
FindReplace "cd", 1, "ab"
End Sub
Sub FindReplace(StrVal As String, i As Long, Optional StrRep As String = "")
Dim ws As Worksheet
Dim Loc As Range
Dim fstAddress As String
Dim bDecision As Variant
For Each ws In ThisWorkbook.Worksheets
'Reset the visited address list on each sheet.
fstAddress = ""
With ws
Set Loc = .Cells.Find(what:=StrVal, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Loc Is Nothing Then
Do
fstAddress = fstAddress & "|" & Loc.Address
Loc.Parent.Activate 'Activate the correct sheet.
Loc.Activate 'and then the cell on the sheet.
bDecision = MsgBox("Replace value?", vbYesNo + vbQuestion, "Replace or Select value?")
If bDecision = vbYes Then
Loc = StrRep 'Raise the blade, make the change.
'Re-arrange it 'til it's sane.
End If
Set Loc = .Cells.FindNext(Loc)
If Loc Is Nothing Then Exit Do
Loop While InStr(fstAddress, Loc.Address) = 0
End If
End With
Next ws
End Sub
I am trying to display specific data in a specific worksheet using a user form.
There is one command button on the user form - Next - that takes the users preferences (option button chosen), opens a new workbook, and displays the desired data (check boxes chosen) in the specific workbook.
There are 6 option buttons and and 6 check boxes. The worksheet that opens is based on the option button preference and depending on what was chosen in the check boxes, the data associated to that topic will display in the worksheet.
How can i loop options buttons and check boxes on a userform and capture which are "selected"?
The data displayed (in a worksheet) from the chosen check boxes depends on the option button chosen e.g. if I chose Finance (option button), and then I chose Photos and Videos (check boxes), I'd like to display data specific to those selections on the appropriate worksheet.
Here is what I have so far:
Private Sub cmdNext_Click()
'declare variables
Dim strFinancial As String, strFamily As String, strSadness As String,
strSchool As String, strRelationship As String, strTime As String
Dim shtFinancial As Worksheet, shtFamily As Worksheet, shtSadness As
Worksheet, shtSchool As Worksheet, shtRelationship As Worksheet,
shtTime As Worksheet, shtData As Worksheet
shtFinancial = Workbooks("PROJECT.xlsm").Worksheets("Financial")
shtTime = Workbooks("PROJECT.xlsm").Worksheets("Time")
shtFamily = Workbooks("PROJECT.xlsm").Worksheets("Family")
shtSadness = Workbooks("PROJECT.xlsm").Worksheets("Sadness")
shtSchool = Workbooks("PROJECT.xlsm").Worksheets("School")
shtRelationship = Workbooks("PROJECT.xlsm").Worksheets("Relationship")
shtData = Workbooks("PROJECT.xlsm").Worksheets("Data")
'set option button selection to string
strFinancial = obFinancial.Value
strFamily = obFamily.Value
strSadness = obSadness.Value
strSchool = obSchool.Value
strRelationship = obRelationship.Value
strTime = obTime.Value
'activate worksheet of chosen stressor (option button)
Select Case True
Case strTime = True
shtTime.activate
Case strFinancial = True
shtFinancial.activate
Case strFamily = True
shtFamily.activate
Case strSadness = True
shtSadness.activate
Case strSchool = True
shtSchool.activate
Case strRelationship = True
shtRelationship.activate
End Select
'ADVICE
'loop through checkboxes HOW ????
'display advice according to option button chosen
If obFinancial.Value = True And Me.cbAdvice.Value = True Then
shtData.Range("A1:A10").Copy Destination:=Sheets("Financial").Range("A1:A10")
End If
If obSadness.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A21:A30").Copy Destination:=Sheets("Sadness").Range("A1:A10")
End If
If obSchool.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A31:A40").Copy Destination:=Sheets("School").Range("A1:A10")
End If
If obRelationship.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A41:A50").Copy Destination:=Sheets("Relationship").Range("A1:A10")
End If
If obTime.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A51:A60").Copy Destination:=Sheets("Time").Range("A1:A10")
End If
End Sub
Here is the userform:
Yes, it's little bit unclear what you trying to do...
Following is a general example how you might loop through CheckBoxes and OptionButtons:
Private Sub CommandButton1_Click()
Dim c As Control, str As String
For Each c In UserForm1.Controls
If TypeName(c) = "CheckBox" Or TypeName(c) = "OptionButton" Then
str = str & IIf(c = True, c.Caption & vbCrLf, "")
End If
Next c
MsgBox "Selected controls" & vbCrLf & str
End Sub
It is a little difficult to see exactly what you want but I can't help wondering if you're looking at VBA in the wrong way. VBA is an event-driven language, meaning that you can capture most interactions the user has with your programme. This should do away with the need to loop through your controls each time, as you could just log selections as the user makes them.
The most obvious thing to do would be to create some kind of sheet/range map, say in a Collection, and then just retrieve the objects you want based on a selection key. The code below is a skeleton of how you could do it - obviously you'd need to expand and adjust it to suit your own needs.
First declare a few variables at module-level (ie very top of your page):
Option Explicit
Private mRangeMap As Collection
Private mOptKey As String
Private mCboxKey As String
Then build your map. In the example below, I've done this in the Userform_Initialize routine, but you could call it anywhere:
Private Sub UserForm_Initialize()
Dim shtRngPair(1) As Object
'Build the range map.
Set mRangeMap = New Collection
With ThisWorkbook 'use name ofyour workbook
Set shtRngPair(0) = .Worksheets("Financial")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A1:A10")
mRangeMap.Add shtRngPair, "Fin|Adv"
Set shtRngPair(1) = .Range("A11:A20")
mRangeMap.Add shtRngPair, "Fin|Pho"
End With
Set shtRngPair(0) = .Worksheets("Sadness")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A21:A30")
mRangeMap.Add shtRngPair, "Sad|Adv"
Set shtRngPair(1) = .Range("A31:A40")
mRangeMap.Add shtRngPair, "Sad|Pho"
End With
Set shtRngPair(0) = .Worksheets("School")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A41:A50")
mRangeMap.Add shtRngPair, "Sch|Adv"
Set shtRngPair(1) = .Range("A51:A60")
mRangeMap.Add shtRngPair, "Sch|Pho"
End With
End With
End Sub
Now you just need the code to store the user inputs. I just have 3 option buttons and 2 checkboxes for an example:
Private Sub cboxAdvice_Click()
mCboxKey = "Adv"
End Sub
Private Sub cboxPhotos_Click()
mCboxKey = "Pho"
End Sub
Private Sub obFinancial_Click()
mOptKey = "Fin"
End Sub
Private Sub obSadness_Click()
mOptKey = "Sad"
End Sub
Private Sub obSchool_Click()
mOptKey = "Sch"
End Sub
Finally, copy the data when the user hits the Next button:
Private Sub cmdNext_Click()
Dim key As String
Dim shtRngPair As Variant
Dim v As Variant
'Create the key
key = mOptKey & "|" & mCboxKey
'Find the relevant range
On Error Resume Next
shtRngPair = mRangeMap(key)
On Error GoTo 0
'Test if the key is valid
If IsEmpty(shtRngPair) Then
MsgBox "Selection [" & key & "] is invalid."
Exit Sub
End If
'Copy the data
v = shtRngPair(1).Value2
With shtRngPair(0)
.Cells.Clear
.Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Activate
End With
End Sub
Update as per OP's comment
Below is the updated code which iterates your checkbox selections. You'd need to add additional code if you wanted them in a specific order:
Option Explicit
Private mRangeMap As Collection
Private mCboxKeys As Collection
Private mOptKey As String
Private Sub cboxAdvice_Change()
UpdateCheckboxList "Adv", cboxAdvice.Value
End Sub
Private Sub cboxPhotos_Change()
UpdateCheckboxList "Pho", cboxPhotos.Value
End Sub
Private Sub UpdateCheckboxList(ele As String, addItem As Boolean)
'Add or remove the item
If addItem Then
mCboxKeys.Add ele, ele
Else
mCboxKeys.Remove ele
End If
End Sub
Private Sub obFinancial_Click()
mOptKey = "Fin"
End Sub
Private Sub obSadness_Click()
mOptKey = "Sad"
End Sub
Private Sub obSchool_Click()
mOptKey = "Sch"
End Sub
Private Sub cmdNext_Click()
Dim key As String
Dim shtRngPair As Variant, v As Variant, cbk As Variant
Dim rng As Range
Dim initialised As Boolean
For Each cbk In mCboxKeys
'Create the key
key = mOptKey & "|" & cbk
'Find the relevant range
On Error Resume Next
shtRngPair = mRangeMap(key)
On Error GoTo 0
If IsEmpty(shtRngPair) Then
'Test if the key is valid
MsgBox "Selection [" & key & "] is invalid."
Else
If Not initialised Then
With shtRngPair(0)
.Cells.Clear
.Activate
Set rng = .Range("A1")
End With
initialised = True
End If
'Copy the data
v = shtRngPair(1).Value2
rng.Resize(UBound(v, 1), UBound(v, 2)).Value = v
'Offset range
Set rng = rng.Offset(UBound(v, 1))
End If
Next
End Sub
Private Sub UserForm_Initialize()
Dim shtRngPair(1) As Object
'Initialise the collections
Set mRangeMap = New Collection
Set mCboxKeys = New Collection
'Build the range map.
With ThisWorkbook 'use name ofyour workbook
Set shtRngPair(0) = .Worksheets("Financial")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A1:A10")
mRangeMap.Add shtRngPair, "Fin|Adv"
Set shtRngPair(1) = .Range("A11:A20")
mRangeMap.Add shtRngPair, "Fin|Pho"
End With
Set shtRngPair(0) = .Worksheets("Sadness")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A21:A30")
mRangeMap.Add shtRngPair, "Sad|Adv"
Set shtRngPair(1) = .Range("A31:A40")
mRangeMap.Add shtRngPair, "Sad|Pho"
End With
Set shtRngPair(0) = .Worksheets("School")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A41:A50")
mRangeMap.Add shtRngPair, "Sch|Adv"
Set shtRngPair(1) = .Range("A51:A60")
mRangeMap.Add shtRngPair, "Sch|Pho"
End With
End With
End Sub
I am now trying to achieve something like the query function in Google Sheets. Obviously in this GIF, someone has already done that. I wonder how they could do that in Excel / VBA.
My specific question is: in VBA, how to fill other cells' formulas by entering a formula in a specific cell? (replicate the function used in this GIF and not using VBA + advanced filter)
Enter a formula in cell A3
Press CTRL + SHIFT + ENTER
Receive results
This is what I got so far:
The code in a standard module:
Sub run_sql_sub(sql)
On Error Resume Next
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
This Workbook.FullName _
& ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
.Open
End With
rs.Open sql, cn
Application.ScreenUpdating = False
ActiveSheet.Range("A1:XFD1048576").ClearContents
For intColIndex = 0 To rs.Fields.Count - 1
Range("A1").Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next
Range("A2").CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close: cn.Close: Set rs = Nothing: Set cn = Nothing
End Sub
And this code is in activesheet's module:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = ActiveSheet.Range("A1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If InStr(KeyCells.Value2, "mi_sql") > 0 Then
sql = Right(KeyCells.Value2, Len(KeyCells.Value2) - Len("mi_sql "))
run_sql_sub sql
End If
End If
End Sub
Update 08.04.2019: found a solution
' Code in standard Module
Public collectCal As Collection
Private ccal As CallerCal
Sub subResizeKQ(caller As CallerInfo)
On Error Resume Next
Application.EnableEvents = False
If caller.Id <> "" Then
Application.Range(caller.Id).ClearContents
Application.Range(caller.Id).Resize(caller.rows, caller.cols).FormulaArray = caller.FomulaText
End If
Application.EnableEvents = True
End Sub
Function ResizeKQ(value As Variant) As Variant
If ccal Is Nothing Then Set ccal = New CallerCal
If collectCal Is Nothing Then Set collectCal = New Collection
Dim caller As New CallerInfo
Dim rows As Long, cols As Long
Dim arr As Variant
arr = value
rows = UBound(arr, 1) - LBound(arr, 1) + 1
cols = UBound(arr, 2) - LBound(arr, 2) + 1
Dim rgcaller As Range
Set rgcaller = Application.caller
caller.Id = rgcaller.Address(True, True, xlA1, True, True)
caller.rows = rgcaller.rows.Count
caller.cols = rgcaller.Columns.Count
caller.FomulaText = rgcaller.Resize(1, 1).Formula
If caller.rows <> rows Or caller.cols <> cols Then
caller.rows = rows
caller.cols = cols
collectCal.Add caller, caller.Id
End If
ResizeKQ = arr
End Function
Function fRandArray(numRow As Long, numCol As Long) As Variant
Application.Volatile True
ReDim arr(1 To numRow, 1 To numCol)
For i = 1 To numRow
For j = 1 To numCol
arr(i, j) = Rnd
Next
Next
fRandArray = ResizeKQ(arr)
End Function
'--------------------------------------------------------------------------
' code in Class Module name CallerCal
Private WithEvents AppEx As Application
Private Sub AppEx_SheetCalculate(ByVal Sh As Object)
Dim caller As CallerInfo
If collectCal Is Nothing Then Exit Sub
For Each caller In collectCal
subResizeKQ caller
collectCal.Remove caller.Id
Set caller = Nothing
Next
Set collectCal = Nothing
End Sub
Private Sub Class_Initialize()
Set AppEx = Application
End Sub
Private Sub Class_Terminate()
Set AppEx = Nothing
End Sub
'--------------------------------------------------------------------------
' code in Class Module name CallerInfo
Public rows As Long
Public cols As Long
Public Id As String
Public FomulaText As String
To test it, go to Excel Sheet, enter the following test formula in A1:
=fRandArray(10,10)
P.S: If anyone is using Excel 365 Insider Program, Microsoft has published this kind of formula called Dynamic Array Function:
https://support.office.com/en-ie/article/dynamic-arrays-and-spilled-array-behavior-205c6b06-03ba-4151-89a1-87a7eb36e531
I agree with the other comments - MS doesn't seem to provide a way to do this natively, and any way of doing it directly would probably involve some Excel-breaking memory manipulation.
However...
I suggest taking your method one step further and generalizing it
Copy and paste this class into a text file, then import it into VBA (which allows Attribute VB_PreDeclaredID = True and Attribute Item.VB_UserMemId = 0):
RangeEdit
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "RangeEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private colRanges As Collection
Private colValues As Collection
Private Sub Class_Initialize()
Set colRanges = New Collection
Set colValues = New Collection
End Sub
Public Property Let Item(rng_or_address As Variant, value As Variant)
Attribute Item.VB_UserMemId = 0
colRanges.Add rng_or_address
colValues.Add value
End Property
Public Sub flush(sh As Worksheet)
Application.EnableEvents = False
While colRanges.Count > 0
If TypeName(colRanges(1)) = "Range" Then
colRanges(1).value = colValues(1)
ElseIf TypeName(colRanges(1)) = "String" Then
sh.Range(colRanges(1)).value = colValues(1)
End If
colRanges.Remove 1
colValues.Remove 1
Wend
Application.EnableEvents = True
End Sub
Make your Workbook_SheetChange method the following:
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
RangeEdit.flush sh
End Sub
Now you can create a UDF that modifies other cells. The way it works is it queues up all the modifications you make and only runs them after the cell loses focus. The syntax allows you to treat it almost like the regular Range function. You can run it either with an address string or with an actual range (though you might want to add an error if it's not either one of those).
Here is a quick example UDF that can be run from an Excel cell formula:
Public Function MyUDF()
RangeEdit("A1") = 4
RangeEdit("B1") = 6
RangeEdit("C4") = "Hello everyone!"
Dim r As Range
Set r = Range("B12")
RangeEdit(r) = "This is a test of using a range variable"
End Function
For your specific case, I would replace
For intColIndex = 0 To rs.Fields.Count - 1
Range("A1").Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next
with
For intColIndex = 0 To rs.Fields.Count - 1
RangeEdit(Range("A1").Offset(0, intColIndex)) = rs.Fields(intColIndex).Name
Next
And to copy the recordset I would define the following function (it assumes that the recordset cursor is set to the first record. if you Move it previously you might want to have rs.MoveFirst in there):
Public Sub FormulaSafeRecordsetCopy(rs As ADODB.Recordset, rng As Range)
Dim intColIndex As Long
Dim intRowIndex As Long
While Not rs.EOF
For intColIndex = 0 To rs.Fields.Count - 1
RangeEdit(rng.Offset(intRowIndex, intColIndex)) = rs.Fields(intColIndex).value
Next
rs.MoveNext
intRowIndex = intRowIndex + 1
Wend
End Sub
My app below checks a workbook which has a list of items sold for a particular month identified with a serial number. There is also a comment column next to the item.
Each month when I run the app it tells me if the same item was sold and the comments next to the item.
"Item found in sheet labeled august 2014"
"Comments for that item"
if I run the app again on the workbook when it gets an additional sheet added, it's going to add the "items found..." Again.
I have the results starting from column 20 and beyond, I only need to delete the duplicates in those columns.
Option Explicit On
Option Infer Off
Imports System.Net.Mail
Imports System.IO
Imports Microsoft.Office.Interop
Imports Microsoft.Office.Interop.Excel
Imports System.Runtime.InteropServices
Imports Excel = Microsoft.Office.Interop.Excel
Imports System.Text.RegularExpressions
Public Class Form1
Dim fileName As String = ""
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
End Sub
Private Function ColumnIndexToColumnLetter(colIndex As Integer) As String
Dim div As Integer = colIndex
Dim colLetter As String = String.Empty
Dim modnum As Integer = 0
While div > 0
modnum = (div - 1) Mod 26
colLetter = Chr(65 + modnum) & colLetter
div = CInt((div - modnum) \ 26)
End While
Return colLetter
End Function
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Button1.Enabled = False
Button1.Text = "Patience"
Button1.Refresh()
System.Windows.Forms.Application.DoEvents()
Dim app As New Excel.Application
app.Visible = False
Dim wbBase As Excel.Workbook = app.Workbooks.Open(TextBox1.Text)
' * create style *
'
Dim xlStyles As Excel.Styles = wbBase.Styles
Dim xlStyle As Excel.Style = Nothing
Dim isstyleexists As Boolean = False
'
' * check if this style exist *
'
For Each xlStyle In xlStyles
If xlStyle.Name = "NewStyle" Then
isstyleexists = True
Exit For
End If
Next
'
' * if this does not exist so add new one *
' ' get Range "A1"
If (Not isstyleexists) Then
xlStyles.Add("NewStyle")
xlStyle = xlStyles.Item("NewStyle")
End If
Dim snName As String
Dim snName2 As String
Dim cmt2 As String
For Each basesheet As Excel.Worksheet In wbBase.Sheets
Dim iiii As Integer = basesheet.Cells(1, basesheet.Columns.Count).End(Excel.XlDirection.xlToLeft).Column + 1
Dim iii As Integer = basesheet.Cells(1, basesheet.Columns.Count).End(Excel.XlDirection.xlToLeft).Column + 1
Dim iv As Integer = iii + 1
For i As Integer = 1 To 20
If Not basesheet.Cells(1, i).Value Is Nothing AndAlso basesheet.Cells(1, i).Value.Contains("Serial Number") Then
snName = ColumnIndexToColumnLetter(i)
Exit For
End If
Next
If Not snName Is Nothing Then
For Each checksheet As Excel.Worksheet In wbBase.Sheets
If basesheet.Name <> checksheet.Name Then
For i As Integer = 1 To 20
If Not checksheet.Cells(1, i).Value Is Nothing AndAlso checksheet.Cells(1, i).Value.Contains("Serial Number") Then
snName2 = ColumnIndexToColumnLetter(i)
Exit For
End If
Next
For i As Integer = 1 To 20
If Not checksheet.Cells(1, i).Value Is Nothing AndAlso checksheet.Cells(1, i).Value.Contains("Comments") Then
cmt2 = ColumnIndexToColumnLetter(i)
Exit For
End If
Next
If Not snName2 Is Nothing Then
Dim baseobj As Object = basesheet.Range(snName & "2:" & snName & basesheet.Range(snName & basesheet.Rows.Count).End(Excel.XlDirection.xlUp).Row).Value
Dim checkobj As Object = checksheet.Range(snName2 & "2:" & snName2 & checksheet.Range(snName2 & checksheet.Rows.Count).End(Excel.XlDirection.xlUp).Row).Value
Dim cmtobj As Object = checksheet.Range(cmt2 & "2:" & cmt2 & checksheet.Range(snName2 & checksheet.Rows.Count).End(Excel.XlDirection.xlUp).Row).Value
Dim basetmp(DirectCast(baseobj, Object(,)).Length, 1) As Object
Dim v As Integer = 0
Dim bool As Boolean = False
For i As Integer = 1 To DirectCast(baseobj, Object(,)).Length
For ii As Integer = 1 To DirectCast(checkobj, Object(,)).Length
If Not baseobj(i, 1) Is Nothing AndAlso Not checkobj(ii, 1) Is Nothing AndAlso Trim(baseobj(i, 1).ToString) = Trim(checkobj(ii, 1).ToString) Then
bool = True
basetmp(i, 0) = "Serial # Exists in " & checksheet.Name
basetmp(i, 1) = cmtobj(ii, 1)
End If
Next
v += 1
Next
If bool Then
basesheet.Range(basesheet.Cells(1, iii), basesheet.Cells(v, iv)).Style = "NewStyle"
basesheet.Range(basesheet.Cells(1, iii), basesheet.Cells(v, iv)).Borders.Weight = Excel.XlBorderWeight.xlThin
basesheet.Range(basesheet.Cells(1, iii), basesheet.Cells(v, iv)).Borders.LineStyle = Excel.XlLineStyle.xlContinuous
basesheet.Range(basesheet.Cells(1, iii), basesheet.Cells(v, iv)).Value = basetmp
basesheet.Cells(1, iii).value = "Results Found"
basesheet.Cells(1, iii).Font.Color = System.Drawing.ColorTranslator.ToOle(System.Drawing.Color.Red)
basesheet.Cells(1, iii).HorizontalAlignment = Excel.Constants.xlCenter
basesheet.Cells(1, iii).Font.Bold = True
basesheet.Columns.AutoFit()
iii += 2
iv += 2
End If
End If
End If
Next
End If
Next
wbBase.Save()
wbBase.Close()
app.Quit()
MessageBox.Show("Done", "Three in Thirty", MessageBoxButtons.OK)
Button1.Text = "Start"
Button1.Enabled = True
End Sub
It looks like you are reprocessing the previously processed sheets each month.
It might be easier to avoid reprocessing old sheets, than to avoid duplicating entries from reprocessing old sheets.
Instead of using nested loops of worksheets, I would probably try a pattern like:
* find basesheet
* find latest checksheet
* process the checksheet for items sold
If users might accidentally add things to old sheets, then I would consider locking old sheets when you do the processing to help ensure data integrity.
I'm just trying to do something very simple with Vlookup, but am getting the 1004 error. Would really, really appreciate your help. Thanks in advance. Here's my code:
Sub test()
Dim user As String
Dim drawn As String
Set Sheet = ActiveWorkbook.Sheets("consolidated")
For i = 2 To 2092
user = CStr(Cells(i, 1).Value)
Set Sheet = ActiveWorkbook.Sheets("sections")
drawn = CStr(Application.WorksheetFunction.VLookup(user, Sheet.Range("A2:B3865"), 2))
Set Sheet = ActiveWorkbook.Sheets("consolidated")
Cells(i, 10).Value = drawn
Next i
End Sub
When you use VLOOKUP as a member of WorksheetFunction, an error will result in a runtime error. When you use VLOOKUP as a member of Application, an error will result in a return value that's an error, which may or may not result in a runtime error. I have no idea why MS set it up this way.
If you use WorksheetFunction, you should trap the error. If you use Application, you should use a Variant variable and test for IsError. Here are a couple of examples.
Sub VlookupWF()
Dim sUser As String
Dim sDrawn As String
Dim shSec As Worksheet
Dim shCon As Worksheet
Dim i As Long
Set shSec = ActiveWorkbook.Worksheets("sections")
Set shCon = ActiveWorkbook.Worksheets("consolidated")
For i = 2 To 2092
sUser = shCon.Cells(i, 1).Value
'initialize sDrawn
sDrawn = vbNullString
'trap the error when using worksheetfunction
On Error Resume Next
sDrawn = Application.WorksheetFunction.VLookup(sUser, shSec.Range("A2:B3865"), 2, False)
On Error GoTo 0
'see if sdrawn is still the initialized value
If Len(sDrawn) = 0 Then
sDrawn = "Not Found"
End If
shCon.Cells(i, 10).Value = sDrawn
Next i
End Sub
Sub VlookupApp()
Dim sUser As String
Dim vDrawn As Variant 'this can be a String or an Error
Dim shSec As Worksheet
Dim shCon As Worksheet
Dim i As Long
Set shSec = ActiveWorkbook.Worksheets("sections")
Set shCon = ActiveWorkbook.Worksheets("consolidated")
For i = 2 To 2092
sUser = shCon.Cells(i, 1).Value
vDrawn = Application.VLookup(sUser, shSec.Range("A2:B3865"), 2, False)
'see if vDrawn is an error
If IsError(vDrawn) Then
vDrawn = "Not Found"
End If
shCon.Cells(i, 10).Value = vDrawn
Next i
End Sub