I want to enter multiple values in a single cell in excel sheet based on the certain condition as in if there are multiple sheets in the workbook then if any of the sheet starting with name TC contains color in it then I've to enter the information in Read Me Section of the Excel Workbook a another worksheet. The problem with my code is that its not displaying unique sheets which contain coloring...Suppose Sheet "TC_1" and "TC_3" contains color in any of the cell then its displaying the output as ";TC_3;TC_3;TC_3;" although the expected output over here is "TC_1;TC_3".
Here, is the code:
Sub ErrorInSheet()
Dim Row
Dim Names As String
Names = ""
For Row = 2 To tsheet.UsedRange.Rows.Count
For Chkcol = 1 To tsheet.UsedRange.Columns.Count
If tsheet.Cells(Row, Chkcol).Interior.ColorIndex = 3 Then
Names = Names & ";" & tsheet.Name
End If
Next
Next Row
Sheets("Read Me").Cells(13, 5).Value = Names
End Sub
Sub iterateSheets()
For Each sheet1t In Worksheets
If InStr(1, sheet1t.Name, "TC") Then
Set tsheet = sheet1t
Call ErrorInSheet
End If
Next
End Sub
I think this will work for you - I tested it and worked for me.
Sub FindErrors()
Dim sht As Worksheet, cl As Range, shtNames As String
shtNames = vbNullString
For Each sht In Worksheets
If Left$(sht.Name, 2) = "TC" Then
For Each cl In sht.UsedRange.Cells
If cl.Interior.ColorIndex = 3 Then
shtNames = IIf(shtNames = vbNullString, sht.Name, shtNames & ";" & sht.Name)
End If
Next cl
End If
Next sht
Worksheets("Read Me").Cells(13, 5) = shtNames
End Sub
Notes:
I've explicitly declared the variables
I am assuming all your sheets start with "TC" so I've used Left$ but you can use InStr if you like
I've used the ternary IIF statement to stop you getting a leading ;
I've put all the code in one Sub but you can split it out if you like
Related
Context: New to VBA
Task: I have a contact list in Worksheet1 which contains columns: LastName, FirstName, email, phone #, and several more. I have a second contact list in Worksheet2 (formatted exactly the same) which contains approximately 500 of the 1,000 names found in the Worksheet1 contact list BUT with updated contact information (email, phone #, etc.). I'm trying to write code to find which names are in both worksheets, and for those names, copy the email, phone#, etc. from Worksheet2 (updated information) and paste it into the corresponding location in Worksheet2.
Code: This is what I have so far. It does not work.
Sub UpdateContacts()
Dim Reference As String
Dim Range As Range
Dim ContactList As Worksheet
Dim UpdatedContacts As Worksheet
ContactList = ActiveWorkbook.Sheets("Contact List")
UpdatedContacts = ActiveWorkbook.Sheets("Updated Contacts")
Reference = ContactList.Range("B5", "C5").Value
j = 5
For i = 5 To UpdatedContacts.Cells(Rows.Count, 1).End(xlUp).Row
If UpdatedContacts.Range(Cells(i, 2), Cells(i, 3)).Value = Reference Then
UpdatedContacts.Range(Cells(i, 4), Cells(i, 17)).Copy _
Destination:=ContactList.Range(Cells(j, 4), Cells(j, 17))
j = j + 1
End If
Next i
End Sub
Any help is greatly appreciated!
Thanks
Here is a working solution with some minor improvements such as Option Explicit, fully qualified references at all times, Option Compare Text to ignore capital letters when comparing the names, Trim to ignore possible leading or trailing spaces, and creating another outer loop to do the comparison for all names on shtContactList:
Option Explicit
Option Compare Text
Sub UpdateContacts()
Dim ws As Worksheet
Dim rngCell As Range
Dim i As Long, j As Long
Dim strReference As String
Dim shtContactList As Worksheet
Dim shtUpdatedContacts As Worksheet
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Contact List"
Set shtContactList = ws
Case "Updated Contacts"
Set shtUpdatedContacts = ws
Case Else
Debug.Print ws.Name
End Select
Next ws
If shtContactList Is Nothing Or shtUpdatedContacts Is Nothing Then
MsgBox "One or more required sheet(s) were not found." & Chr(10) & "Aborting..."
Exit Sub
End If
For j = 5 To shtContactList.Cells(shtContactList.Rows.Count, "A").End(xlUp).Row
strReference = Trim(shtContactList.Cells(j, 2).Value2) & ", " & Trim(shtContactList.Cells(j, 3).Value2)
For i = 5 To shtUpdatedContacts.Cells(shtUpdatedContacts.Rows.Count, 1).End(xlUp).Row
If Trim(shtUpdatedContacts.Cells(i, 2).Value2) & ", " & Trim(shtUpdatedContacts.Cells(i, 3).Value2) = strReference Then
shtUpdatedContacts.Range(shtUpdatedContacts.Cells(i, 4), shtUpdatedContacts.Cells(i, 17)).Copy _
Destination:=shtContactList.Range(shtContactList.Cells(j, 4), shtContactList.Cells(j, 17))
j = j + 1
End If
Next i
Next j
End Sub
If the code is running slow you might want to consider using an array: (1) put the entire sheet shtUpdatedContacts into an array as well as the sheet shtContactList and (2) then make the search / comparison there. (3) Finally, paste the updates array back to sheet shtContactList.
I have an excel document with ~300 similar worksheets and 1 worksheet with a list of names. Each of these 300 worksheets has a specific cell where I need to fill a name from the list. The list and the sheets are in the same order (for example sheet1 needs a name from List!C1, sheet2 from List!C2 etc). I looked into VLOOKUP, but there isn't any reference data I can use.
I think for similar task you need use VBA Macros like this:
Sub DataFromList()
Dim nameSht As String: nameSht = "List"
Dim shtList As Worksheet
Set shtList = ThisWorkbook.Worksheets(nameSht)
Dim columnWithData As String: columnWithData = "C"
Dim n%: n = 0 ' start from 1 row (0 + 1)
' specific cell where you need to fill a name from the list
Dim addressForData As String: addressForData = "B2"
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> nameSht Then
n = n + 1
sht.Range(addressForData).Formula = "=" & nameSht & "!" & columnWithData & n
End If
Next sht
End Sub
of course, it possible only if address of "specific cell" same in all sheet
I am hoping someone can assist me with a sheet array issue I am having. For background information, the main "template" sheet is copied multiple times as a new input is stored in each version. The newly created sheet is named after the input. The inputs are almost random, so defining by sheetname is not an option.
Once the workbook has all of the new sheets added I am trying to isolate a subset of the sheets. The problem I run into is the sheet numbers (as seen in the project window) don't necessary go in order. Also many sheets are hidden.
The following code is portion being used to create the sheet array, which breaks upon trying to save the array as a variable (objsheets).
Not sure what I am missing to have this array saved. Any help would be greatly appreciated. Code Below.
Thanks,
JM
At this point the workbook has the "template" sheet copied and has 50 new sheets added (hypothetical number).
Sub SheetArrayTest
Dim mySheet As Object
Dim objShts As Excel.Sheets
Dim varArray As Variant
Dim FirstSheetNum As Long
Dim FirstSheet As String
Dim LastSheetNum As Long
Dim LastSheet As String
'Selects template sheet
Sheets("Template").Select
'Selects the first sheet following the template sheet, and is the desired start of the array
Sheets(ActiveSheet.Index + 1).Activate
'Creates variables for starting point
FirstSheet = ActiveSheet.Name
FirstSheetNum = ActiveSheet.Index
'Loops through each sheet in the workbook following the "FirstSheet" and selects it to create the array
For Each mySheet In Sheets
With mySheet
If .Visible = True And mySheet.Index >= FirstSheetNum Then .Select Replace:=False
End With
LastSheetNum = mySheet.Index
LastSheet = Sheets(LastSheetNum).Name
If FirstSheetNum < LastSheetNum Then
'Attempt at preserving the array
ReDim varArray(FirstSheetNum To LastSheetNum)
varArray(LastSheetNum) = LastSheet
End If
Next mySheet
'ERROR
Set objShts = Sheets(varArry)
...
End Sub
You can't use the Set keyword to assign to an array. That's your first problem, and would explain an error on that line.
Set objSheets = Sheets(varArray)
That line may also fail because the Sheets takes an index value, not an array of values.
You're also not preserving the array with ReDim Preserve to extend it.
In any case... let's see if we can't figure it out. it sounds like you're trying to store an array of Sheet/Worksheet Objects. But your code is assigning a string value to your array (LastSheet), rather than an object.
Instead of storing the sheet name (LastSheet) in the array, store the sheet itself (unless you really need the index value).
You can maybe modify this:
Dim numberOfSheets as Integer
numberOfSheets = -1
For Each mySheet In Sheets
With mySheet
If .Visible = True And mySheet.Index >= FirstSheetNum Then .Select Replace:=False
End With
LastSheetNum = mySheet.Index
LastSheet = Sheets(LastSheetNum).Name
If FirstSheetNum < LastSheetNum Then
'increase the size of the array
numberOfSheets = numberOfSheets + 1
ReDim Preserve varArray(numberOfSheets)
Set varArray(numberOfSheets) = Sheets(LastSheet)
End If
Next mySheet
You do not need the variable objSheets at all.
Sub M_snb()
For Each sh In Sheets
If sh.Visible = -1 And sh.Name <> "template" Then c00 = c00 & "|" & sh.Name
Next
Sheets(Split(Mid(c00, 2), "|")).Select
End Sub
Sub M_snb()
For Each sh In Sheets
If sh.Visible = -1 And sh.Name <> "template" Then c00 = c00 & "|" & sh.Name
Next
Sheets(Split(Mid(c00, 2), "|")).Select
End Sub
courtesy of snb
I'm trying to create a macro that compares two user in-putted worksheets then moves the differences to different sheets depending on why its different.
The code first asks for input of the newest data and opens that sheet. Then it asks for the location of the older data to compare with but doesn't open it. It adds the necessary sheets to copy to.
It then goes down a column cell by cell looking for the matching serial on the second work book (this is mainly to ensure that its comparing the correct data in-case formatting is off). Once it finds the matching serial it compares the second serial for both entry's and depending on if its different or new input into one of the sheets.
The main issue I'm having is with VLookup. It is having multiple errors 424, 1004 and Compile expression errors. I need a little guidance as to why its having these issues. I have searched and found a lot on needing to have brackets to reference a file but when I follow those formats exactly it throws the expression error.
Any advice is appreciated.
Sub Compare()
'Open workbooks
''Worksheet 1
Dim filter As String
Dim caption As String
Dim WB1FN As String
Dim WB1 As Workbook
filter = "Excel Sheets (*.xlsx),*.xlsx"
caption = "Please select newest equipment file"
MsgBox (caption)
WB1FN = Application.GetOpenFilename(filter, , caption)
If WB1FN = "False" Then
MsgBox "File not selected to import"
Exit Sub
End If
Set WB1 = Application.Workbooks.Open(WB1FN)
''Worksheet 2
Dim caption2 As String
Dim WB2FN As String
filter = "Excel Sheets (*.xlsx),*.xlsx"
caption2 = "Please select previous equipment file"
MsgBox (caption2)
WB2FN = Application.GetOpenFilename(filter, , caption)
If WB2FN = "False" Then
MsgBox "File not selected to import"
Exit Sub
End If
'Comparing data
''MS find and compare
Dim MS1 As String
Dim ESN1 As String
Dim ESN2 As String
Dim LastRow As Long
Dim i As Integer
Dim d As Integer
Dim n As Integer
Dim Filename As String
d = 4
n = 4
Set WB1 = ActiveWorkbook
'Create sheets
Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "A"
Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "B"
Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "C"
'Gets the last row number
ActiveWorkbook.Sheets(1).Activate
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 4 To LastRow
''Assigning MS1,ES1,ES2
MS1 = Cells(i, 6)
ESN1 = Cells(i, 15)
ESN2 = Application.WorksheetFunction.VLookup(MS1, '[" & WB2FN & "]Sheet1'! [R3C6:R10000C15], 10, False)
''Compare ESN and copy data
If ESN2 <> ESN1 Then
cell.EntireRow.Copy Sheets(2).Cells(d, 1)
n = d + 1
ElseIf Application.WorksheetFunction.IsNA(ESN2) = "TRUE" Then
cell.EntireRow.Copy Sheets(4).Cells(n, 1)
n = n + 1
End If
Next i
'X find and copy
Dim OEM As String
ActiveWorkbook.Sheets(2).Activate
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
n = 3
i = 3
For i = 3 To LastRow
''Check for X
OEM = Cells(i, 4)
If OEM = "x" Then
cell.EntireRow.Copy Sheets(3).Cells(n, 1)
n = n + 1
End If
Next i
MsgBox "Compare successful"
End Sub
have brackets to reference a file You can only use that approach if you are assigning a formula to a cell or range.
Example:
Dim myformula As String
myformula = "=VLOOKUP(" & MS1 & _
",'[" & WB2FN & "]Sheet1'! [R3C6:R10000C15], 10, False)"
Range("A1").Formula = myformula
But if you use VBA Worksheet Function, you need to somehow access the database or table you are fetching data from at runtime. Meaning you have to pass objects on the arguments and not strings as you do in above.
Something like:
'~~> the rest of your code before Vlookup here
Dim wb As Workbook
Dim mytable As Range
Set wb = Workbooks.Open(WN2FN, , True) '~~> read only, avoid errors when file in use
Set mytable = wb.Sheets("Sheet1").Range("F3:O10000")
On Error Resume Next '~~> to handle when Vlookup returns #N/A or errors out
ESN2 = Application.WorksheetFunction.VLookup(MS1, mytable, 5, 0)
If Err.Number <> 0 Then myvalue = CVErr(xlErrNA)
On Error GoTo 0 '~~> reset error handling to trap other errors
Debug.Print ESN2
I just provided the part where you use the Vlookup WorksheetFunction. You can use the rest of your code before it. Basically above code:
assigns source table to variable and passed it directly to Vlookup arguments.
Uses Vlookup via VBA WorksheetFunction to fetch data.
Take note of the OERN (On Error Resume Next) routine and OEG0 (On Error Goto 0).
In VBA when a Worksheet Function returns an error (eg. #N/A for Vlookup), the code errors out and stops execution. There is no IFERROR like we have in worksheet formulas. So you need to handle it using error handling routines.
Also take note that it is better to fully qualify the objects you're working on.
This is a good place to start to optimize your codes and avoid runtime errors.
I need to copy the contents of cells A2 to A88 and C2 to C88 based on the contents of what is in cells in column G from several spreadsheets in a workbook to the Summary sheet.
So I need code to scan all spreadsheets to see if the word Case closed is in cell G33 and than copy the contents of cell A33 and C33 to a cell on the summary page.
I have seen several close answers but nothing that does the job.
Sorry no code available.
Thanks for any and all answers.
You could create some vba if you cannot solve this using excel formulas... I made a little test excel sheet with following vba code:
Sub test()
processSheet Application.ActiveWorkbook, "Sheet1"
End Sub
Function FindSheet(currentWorkbook As Workbook, sheetName As String) As Worksheet
If currentWorkbook Is Nothing Then
Err.Raise vbObjectError + 1, "FindSheet", "Supplied workbook is nothing"
End If
Dim idx As Integer
For idx = 1 To currentWorkbook.Sheets.Count
Dim checkSheet As Worksheet
Set checkSheet = currentWorkbook.Sheets.Item(idx)
If checkSheet.Name = sheetName Then
Set FindSheet = checkSheet
Exit Function
End If
Next
End Function
Function IsEmpty(currentCell As Range) As Boolean
IsEmpty = False
If currentCell.Value = "" And currentCell.Value2 = "" Then
IsEmpty = True
End If
End Function
Sub processSheet(currentWorkbook As Workbook, sheetName As String)
On Error GoTo Catch
Dim currentSheet As Worksheet
Set currentSheet = FindSheet(currentWorkbook, sheetName)
If currentSheet Is Nothing Then
Err.Raise vbObjectError + 2, "ProcessSheet", "Could not find sheet " + sheetName
End If
Dim colA As Range
Dim colB As Range
Dim colCondition As Range
Dim colResult As Range
currentSheet.Activate
Set colA = currentSheet.Columns(1)
Set colB = currentSheet.Columns(2)
Set colCondition = currentSheet.Columns(3)
Set colResult = currentSheet.Columns(4)
Dim index As Integer: index = 2
Dim run As Boolean: run = True
Do While run
If IsEmpty(colA.Rows(index)) And IsEmpty(colB.Rows(index)) And IsEmpty(colCondition.Rows(index)) Then
run = False
Else
index = index + 1
If colCondition.Rows(index).Value = "Closed" Then
resultContent = CStr(colA.Rows(index).Value2) + ": " + CStr(colB.Rows(index).Value2)
Else
resultContent = "-"
End If
colResult.Rows(index).Value2 = resultContent
End If
Loop
GoTo Finally
Catch:
MsgBox ("An error occured: " + Err.Description)
Exit Sub
Finally:
End Sub
You can just put this macro in the macros of a new workbook. Open the Sheet1 and add 4 columns. I added a screenshot of how the excel sheet looks like.
As a new user I'm not allowed to post images.. so here is the link: Sheet1
Short explanation of the code.
A workbook is passed and a sheet selected by a sheet name
If the sheet is available the script runs through the three dependent columns (two columns needed for concatenation and one for the condition) and checks if the values are set. The loop stops when all the three columns do not contain any value (in your case you could hardcode the start and end index, if it always stays the same).
During the iteration, the condition field is checked. If it is equals "Closed", the result cell is filled with the first two columns values concatenated.
You certainly need to adapt the code to your problem, but shouldn't be a big thing to do.