VBA - Prevent the Adding of Multiple Sheets - excel

The purpose of my macro is to allow a user to select a range in their model that they want to check for hard codes. The macro then prints the worksheet, cell address, and value of the hard code on a summary sheet. The macro currently works great if you're selecting only from one sheet; however, if you extend your selection to multiple sheets, the macro will create multiple sheets instead of just one which it is intended to do. Thank you in advance for your time and help
Set RngCon = Selection.SpecialCells(xlCellTypeConstants, xlNumbers)
Set SumWS = Worksheets.Add
Username = InputBox("Please create a name for the output sheet (i.e. Whs Industry Hard Codes)")
SumWS.Name = Username
x = 1
SumWS.Cells(x, 1) = "Worksheet"
SumWS.Cells(x, 2) = "Address"
SumWS.Cells(x, 3) = "Value"
For Each c In RngCon
x = x + 1
SumWS.Cells(x, 1) = c.Worksheet.Name
SumWS.Cells(x, 2) = c.Address(False, False)
SumWS.Cells(x, 3) = c.Value
Next c

you could do something like that:
Sub test()
Dim SumWS As Worksheet
Dim ws As Worksheet
Dim SelectedSheets() As String
Dim n As Long
Dim i As Long
n = 0
For Each ws In ActiveWindow.SelectedSheets
ReDim Preserve SelectedSheets(n)
SelectedSheets(n) = ws.Name
n = n + 1
Next
Sheets(SelectedSheets(0)).Select
Set SumWS = Worksheets.Add
Debug.Print "Sum Sheet: " & SumWS.Name
For i = LBound(SelectedSheets) To UBound(SelectedSheets)
Debug.Print "Selected Sheet #" & i & ": " & SelectedSheets(i)
Next i
End Sub
In the first for you save the selected sheets in an array. Then you can select one specific sheet and add your sum sheet. The second for shows how to work with the stored information. You can loop the selected sheets to get all values and - if needed - select them again.
credits to Siddharth Rout (Similar case)

Related

Excel VBA create new sheet and copy text into cell

I have been using the below code successfully for years but recently it has stopped working. I've since upgraded to Office 365 and still no joy. Essentially the code should copy the Sheet "Response", paste a copy of a cell from "Database" and name the new sheet appropriately. It continues creating new sheets in the workbook until the end of the Database list.
If I run the code as is I get the following: "Run-time error '1004': Microsoft Excel cannot paste the data." When I look at the worksheets, evidentally the code runs and creates a sheet "Response4" (I've only given the database 4 lines to copy). Debug highlights the line ActiveSheet.Paste link:=True. I tested
Frustratingly the code works outside of my company's system (i.e., I sent it to a friend with dummy data and it worked perfectly fine).
Any suggestions very welcome!
Sub CopyCatView()
'NumResp = last row with a responses to the question held within the question 'Themes' database sheet
Dim NumResp As Integer
'x for looping variable
Dim x As Integer
'y for response number variable
Dim y As Integer
Dim ws As Worksheet
Sheets("Database").Activate
NumResp = Range("NumRowsD1").Value + 2
'NumRowsD1 is a named range comprising cell A1 on the Database sheet, which calculates by formula the number of comments in the database
For x = 3 To NumResp
Sheets("Response").Copy before:=Sheets("Response")
y = NumResp - x + 1
ActiveSheet.Name = "Response" & y
ActiveSheet.Range("C2").Value = Sheets("Database").Range("B" & x).Value
ActiveSheet.Range("AA5:CR5").Select
Selection.Copy
Sheets("Database").Select
Cells(x, 3).Select
ActiveSheet.Paste link:=True
Sheets("Response" & y).Activate
ActiveSheet.Range("F4").Select
Selection.Copy
Sheets("database").Select
Cells(x, 70).Select
ActiveSheet.Paste link:=True
'duplicates the Response sheet as many times as there are comments (=X), numbers them Response1 to ResponseX, copies each comment into the white box on a different response sheet from Response1 to ResponseX
'Also links through the check box reporting to the relevant row in the Database sheet
Next x
'at the end hide Sheet "Response"(deleting brings up prompts for every sheet deleted!)
Sheets("Response").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Database").Activate
Range("A1").Select
End Sub
Since the "paste with link" requires ranges to be selected before pasting, I'd skip that and create a method to perform that function.
Also - use worksheet variables to reduce the repetition in your code and make for easier maintenance.
Sub CopyCatView()
Dim NumResp As Long, x As Long, y As Long 'prefer Long over Integer
Dim wsDB As Worksheet, wsResp As Worksheet, ws As Worksheet
Set wsDB = ThisWorkbook.Worksheets("Database")
Set wsResp = ThisWorkbook.Worksheets("Response")
NumResp = wsDB.Range("NumRowsD1").Value + 2
For x = 3 To NumResp
wsResp.Copy before:=wsResp
Set ws = ThisWorkbook.Sheets(wsResp.Index - 1) 'get a reference to the copy
y = NumResp - x + 1
ws.Name = "Response" & y
ws.Range("C2").Value = wsDB.Range("B" & x).Value
LinkRanges ws.Range("AA5:CR5"), wsDB.Cells(x, 3)
LinkRanges ws.Range("F4"), wsDB.Cells(x, 70)
Next x
wsResp.Visible = False
wsDB.Activate
wsDB.Range("A1").Select
End Sub
'Link two ranges in the same workbook
' rngFrom = contiguous (single-area) source range
' rngTo = top-left cell of the destination range
Sub LinkRanges(rngFrom As Range, rngTo As Range)
Dim r As Long, c As Long, nm As String
If Not rngFrom.Parent Is rngTo.Parent Then
nm = "'" & rngFrom.Parent.Name & "'!"
End If
For r = 1 To rngFrom.Rows.Count
For c = 1 To rngFrom.Columns.Count
rngTo.Cells(r, c).Formula = "=" & nm & _
rngFrom.Cells(r, c).Address(False, False)
Next c
Next r
End Sub

Excel Data Row Consolidation

I'm trying to come up with a tool to be able to consolidate row data into one line item in Excel. Below is an example:
I want to be able to consolidate record 0604, with the staggered data, into one line item across and remove the duplicates.
Note: this is a limited sample. The real data set can contain more columns (up to 60) with the possibility of 20 duplicate ID that are staggered and needs to be consolidated.
The software that I'm extracting the data from provide this as an output. I'm unable to channel this through a SQL software due to limited access. I know SQL will make this a bit easier, but I was wondering if this can be done in Excel.
Scan up the sheet and compare each cell with the one below and copy from below if blank. Delete row below if it has the same ID
Option Explicit
Sub consolidate()
Const SHEET_NAME = "Sheet1"
Const NO_OF_COLS = 30
Dim wb As Workbook, ws As Worksheet
Dim irow As Long, iLastRow As Long, c As Long, count As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(SHEET_NAME)
iLastRow = ws.Range("A" & Rows.count).End(xlUp).Row
' scan up sheet
For irow = iLastRow - 1 To 2 Step -1
' if same id below
If ws.Cells(irow + 1, 1) = ws.Cells(irow, 1) Then
' scan across
For c = 1 To NO_OF_COLS
' if blank copy from below
If Len(ws.Cells(irow, c)) = 0 Then
ws.Cells(irow, c) = ws.Cells(irow + 1, c)
End If
Next
ws.Rows(irow + 1).Delete
count = count + 1
End If
Next
MsgBox iLastRow - 1 & " rows scanned" & vbCr & _
count & " rows deleted from " & ws.Name, vbInformation
End Sub
If I understand right you could do this with the concatenate function in excel to combine all of the cells together in one cell.
I believe this is what you were asking?
This is an example of how to use that:
=CONCAT(A1,"-",B1)
And whatever cell this is typed into will have cell "A1-B1" as a value (with the values within those cells instead of the cell names).

Excel VBA: Loop through two columns in sheet1, look for specific names, paste rows with matching value to sheet2

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.

Excel autofill between worksheets

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

Vlookup Syntax and user input issues

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.

Resources