I know how to populate a sheet with specific hyperlinks to all the sheets in a given workbook, but how do I exclude certain sheets from being listed?
I have listed the VB below for what I was using. I would like to exclude certain sheets like "Test Results" etc.
Sub GetHyperlinks()
Dim ws As Worksheet
Dim i As Integer
i = 9
For Each ws In ThisWorkbook.Worksheets
ActiveWorkbook.Sheets("overview").Hyperlinks.Add _
Anchor:=ActiveWorkbook.Sheets("overview").Cells(i, 1), _
Address:="", _
SubAddress:="'" & ws.NAme & "'!A1", _
TextToDisplay:=ws.NAme
i = i + 1
Next ws
End Sub
Sub GetHyperlinks()
Dim arrExclude
Dim ws As Worksheet
Dim i As Integer
'Sheets to be excluded from linking
arrExclude = Array("Test Results", "some other sheet", "overview")
i = 9
For Each ws In ThisWorkbook.Worksheets
'test to see if not excluded
If IsError(Application.Match(ws.Name, arrExclude, 0)) Then
ActiveWorkbook.Sheets("overview").Hyperlinks.Add _
Anchor:=ActiveWorkbook.Sheets("overview").Cells(i, 1), _
Address:="", _
SubAddress:="'" & ws.Name & "'!A1", _
TextToDisplay:=ws.Name
i = i + 1
End If 'include this sheet
Next ws
End Sub
Related
At some point I need to consolidate data (simply sum duplicated items). I would like to parameterize Sources:= argument - actually everything works the way I amused when using option after single quote mark. When using src variable I'm getting: Cannot open consolidation source file (picture attached). Looking forward for some tips.
Here is the code:
Sub Format()
' Keyboard Shortcut: Ctrl+Shift+C
'Definition
Dim wb As Workbook
Dim ws As Worksheet
Dim rg As Range
Dim lRow As Integer
Dim src As String
Set wb = ActiveWorkbook
Set ws = ThisWorkbook.ActiveSheet
'Format data
Range("H2").Select
ActiveCell.FormulaR1C1 = "=RC[-5]&""*""&RC[-4]&""*""&RC[-3]&""*""&RC[-2]"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=RC[-7]"
' Find the last non-blank cell in column B(2)
lRow = Cells(Rows.Count, 2).End(xlUp).Row
Set rg = Range("H2", Cells(lRow, 9))
' AutoFill of formated data
Range("H2:I2").Select
Selection.AutoFill Destination:=rg, Type:=xlFillDefault
'Consolidate
src = """" & "'" & wb.Path & "\[" & wb.Name & "]" & ws.Name & "'!R2C8:R" & lRow & "C9" & """"
Debug.Print src
'Range("K2").Consolidate Sources:= _
"'C:\Users\pl1aji0\Documents\Projekty\USA\2020\L034.00080 Innovation\700\BPM\[test.xlsx]Sheet1'!R2C8:R11C9" _
, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
Range("K2").Consolidate Sources:= _
src _
, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
End Sub
I've tried changing everywhere there was a cell to a range and other things but I can't figure it out. I'd like for the code to search the entire sheet, instead of one cell, for these names and paste the information of the cell to the right of it to the other sheet.
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet, myCounter As Long
Dim erow As Long, myValue As Long
Dim nextValue As Long
For Each ws In ThisWorkbook.Sheets
With ws
Select Case .Range("C3").Value
Case "David", "Andrea", "Caroline"
myCounter = 1 ' raise flag >> found in at least 1 sheet
' get first empty row in "Report" sheet
erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Report").Cells(erow, 1) = .Range("C3").Value
End Select ' Select Case .Range("C3").Value
End With
Next ws
If myCounter = 0 Then
MsgBox "None of the sheets contains the names " & Chr(10) & " 'David', 'Andrea', 'Caroline' in cell C3 ", vbInformation, "Not Found"
End If
End Sub
You can use Application.Match with array version. Substitute this for your loop:
Dim ar, r
For Each ws In ThisWorkbook.Sheets
ar = Application.match(Array("David", "Andrea", "Caroline"), ws.Columns("C"), 0)
For Each r In ar
If Not IsError(r) Then
myCounter = 1 ' raise flag >> found in at least 1 sheet
erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).row
Worksheets("Report").Cells(erow, 1) = ws.Range("C" & r).value
Worksheets("Report").Cells(erow, 2) = ws.Range("D" & r).value
End If
Next r
Next ws
Notice though, that this will find you only one match for each word, the first one. If each word can be repeated many times and you want to find all matches, it will need some modification.
Multiple rows and multiple columns would be better served by the Find command.
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
'If ws.Name <> Worksheets("Report").Name Then
If ws.Name = "Sheet7" Then
With ws.Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
With Worksheets("Report")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = rFound.Value
End With
End If
Next a
End With
End If
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub
I have looked at many posts and cannot seem to get this right. I have a userform that take a codename and then creates a sheet with that name, then adds a link to the new sheet as the last cell in Column B on another sheet. I have used 3 different methods to insert the hyperlink, but all of them just return a blank cell, while if I change the value to any string, it works.
Dim sh As Worksheet
Dim codename As String
Dim lastrow As Long
Dim cont As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
codename = InputBox("What is the codename?")
Sheets("XXX").Visible = True
Sheets("XXX").Copy After:=Worksheets("YYY")
ActiveWindow.ActiveSheet.name = codename
Sheets("XXX").Visible = False
Worksheets(YYY).Activate
lastrow = Sheets("YYY).Range("B" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("B" & lastrow).End(xlUp).Offset(1).Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:=sh & "!A1", TextToDisplay:=codename
ActiveSheet.Range("B" & lastrow).End(xlUp).Offset(2).Activate
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:=sh.name & "!A1", TextToDisplay:=codename
ActiveSheet.Range("B" & lastrow).End(xlUp).Offset(3) = codename
ActiveSheet.Range("B" & lastrow).End(xlUp).Offset(4).Hyperlinks.Add Anchor:=Sheets(codename).Cells(1, 1), _
Address:="", SubAddress:=sh, TextToDisplay:=codename
Application.ScreenUpdating = True
I know I have 4 iterations of essentially the same thing. The point is is that no matter if I use 1 of them, or all 4, I get 3 blank cells and (codename) as plaintext, showing that I am obviously missing something easy that I for the life of me cannot figure out. Thanks to all responses.
The reason the links aren't working might be because you use the worksheet object sh without declaring it, and specifically, without declaring it as the new sheet.
In my solution I've only tested it using the .Add method that I included out-commented.
Sub test()
Dim sh As Worksheet, nsh As Worksheet ' sh = YYY, nsh = codename
Dim nrng As Range
Dim codename As String
Dim lastrow As Long
Dim cont As Worksheet
codename = InputBox("What is the codename?")
Set sh = Sheets("YYY")
Sheets("XXX").Visible = True
Sheets("XXX").Copy After:=Worksheets("YYY")
ActiveWindow.ActiveSheet.Name = codename
Sheets("XXX").Visible = False
'Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = codename ' if needed
sh.Activate
lastrow = sh.Range("B" & Rows.Count).End(xlUp).Row + 1
sh.Hyperlinks.Add _
Anchor:=sh.Range("B" & lastrow), _
Address:="", _
SubAddress:="'" & codename & "'!A1", _
TextToDisplay:=codename
End Sub
Shamelessly stolen from myself.
Sub Tester()
DoHyperlink Sheets("Sheet1").Range("F10"), _
Sheets("Sheet 2").Range("E12"), _
"Click Me"
End Sub
'assumes rngFrom and rngTo are in the same workbook...
Sub DoHyperlink(rngFrom As Range, rngTo As Range, LinkText As String)
rngFrom.Parent.Hyperlinks.Add Anchor:=rngFrom, Address:="", _
SubAddress:="'" & rngTo.Parent.Name & "'!" & rngTo.Address(), _
TextToDisplay:=LinkText
End Sub
If I get you right, you are trying to do this... But don't understand why it's "YYY" (not dynamic).
Option Explicit
Sub AddSheetAndLinkIt()
Dim codename As String
Dim oWS As Worksheet, oRng As Range
codename = InputBox("What is the codename?")
' Check if codename already exists
On Error Resume Next
Set oWS = ThisWorkbook.Worksheets(codename)
If Not oWS Is Nothing Then
MsgBox "The worksheet for """ & codename & """ already exists! You cannot create it again.", vbExclamation + vbOKOnly
Exit Sub
End If
' Copy worksheet "XXX" and add hyperlink to "YYY"
Set oWS = ThisWorkbook.Worksheets("YYY")
Set oRng = oWS.Range("B" & Rows.Count).End(xlUp)
ThisWorkbook.Worksheets("XXX").Copy After:=oWS
With ThisWorkbook.Worksheets("XXX (2)")
.Name = codename
.Visible = True
.Activate
End With
oWS.Hyperlinks.Add oRng, "", "'" & codename & "'!A1", "Go to " & codename, codename
Set oRng = Nothing
Set oWS = Nothing
End Sub
I have a little tricky VBA I'm trying to create. What I currently have is two other macros which search two sheets for vendor names and creates new sheets with their specific information. This leaves me with approx 40 sheets, now what I'm trying to do is write a macro that will search for the vendor name in the sheet title and save all the sheets associated with that vendor to a new workbook (if a file exists update the current sheets in that workbook). I will have a list of vendors in one sheet that I would like to use as the search criteria. Here is an example of the first macro I run
Sub ERP_POS()
Dim ws1 As Worksheet Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Dim bAF As Boolean
Set ws1 = Sheets("ERP_POS")
Set rng = Range("Database") bAF = ws1.AutoFilterMode
'extract a list of Sales Reps With ws1
.Columns("P:P").Copy _
Destination:=.Range("X1")
.Columns("X:X").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("Y1"), Unique:=True
r = .Cells(Rows.Count, "Y").End(xlUp).Row
.Columns("X:X").ClearContents
'set up Criteria Area
.Range("X1").Value = .Range("P1").Value
For Each c In .Range("Y2:Y" & r)
'add the rep name to the criteria area
.Range("X2").Value = _
"=""="" & " & Chr(34) & c.Value & Chr(34)
'add new sheet (if required)
'and run advanced filter
If WksExists("ERP_POS" & " " & c.Value) Then
Sheets("ERP_POS" & " " & c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=Sheets("ERP_POS" & " " & c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = "ERP_POS" & " " & c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
.Select
.Columns("Y:X").EntireColumn.Delete
If bAF = True Then
.Range("A1").AutoFilter
End If
End With
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
And here is where I have gotten using that and recoring my own macro but haven't figured out how to create the array function with variables derived from the search, or to get the search to work at creating the c.value.
Sub Test1234() ' ' Test1234 Macro ' Dim ws As Worksheet Dim ws2 As
Worksheet ws = Worksheet.Name
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "*CompanyA*" Then
Set ws2 = Worksheet.Name
Sheets(ws2).Select
Sheets(ws2).Copy
ActiveWorkbook.SaveAs filename:="C:\Users\xxxxx\Desktop\Lovley.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
Next ws
End Sub
Try this code:
Option Explicit
Option Base 1 'Ensure to have this command at the top of the module
Sub Lst_Vendors_Wbk_Set()
Const kPath As String = "D:\StackOverFlow\Answers\" 'Change as required
Dim rTrg As Range, rCll As Range, sVendor As String
'Assuming list of vendors is located at Wsh [Vendors] Column [A] - change as required
With ThisWorkbook.Sheets("Vendors")
Rem Set Target Range
Set rTrg = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
Rem Work List of Vendors
For Each rCll In rTrg.Cells
sVendor = rCll.Value2
If Not sVendor = Empty Then
If Not (Wsh_Find_And_Copy_To_New_Wbk(sVendor, kPath)) Then
MsgBox "No sheet found for vendor: [" & sVendor & "]"
End If: End If: Next: End With
End Sub
Function Wsh_Find_And_Copy_To_New_Wbk(sKey As String, sPathFilename As String) As Boolean
Dim Wsh As Worksheet, aWsh() As String
Rem Validate Key
If sKey = Empty Then GoTo ExitTkn
Rem Get Worksheet Array To Be Copied Into A New Wbk
If IsEmpty(aWsh) Then Stop
For Each Wsh In ThisWorkbook.Worksheets
If Wsh.Name Like "*" & sKey & "*" Then
On Error Resume Next
ReDim Preserve aWsh(1 + UBound(aWsh))
If err.Number <> 0 Then ReDim Preserve aWsh(1)
On Error GoTo 0
aWsh(UBound(aWsh)) = Wsh.Name
End If: Next
Rem Copy Worksheet Array Into A New Wbk
On Error GoTo ExitTkn
ThisWorkbook.Sheets(aWsh).Copy
ActiveWorkbook.SaveAs Filename:=sPathFilename & sKey, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Rem Set Results
Wsh_Find_And_Copy_To_New_Wbk = True
ExitTkn:
End Function
Suggest to visit the following pages:
Excel Objects, For Each...Next Statement, On Error Statement
Range Object (Excel), Variables & Constants, Workbook Object (Excel)
Worksheet Object (Excel), With Statement
I want to copy selected columns of a file from a worksheet to a new workbook using VBS in Excel. The following code gives the empty columns in new file.
Option Explicit
'Function to check if worksheets entered in input boxes exist
Public Function wsExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
wsExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0 ' now it will error on further errors
End Function
Sub createEndUserWB()
Dim i As Integer
Dim colFound As String
Dim b(1 To 1) As Integer
Dim Sheet_Copy_From As String
Dim newSheet As String
Dim colVal As Variant 'sheet name from array to test
Dim colNames As Variant 'Array
Dim col As Variant
Dim colN As Integer
Dim lkr As Range
Dim destWS As Worksheet
Dim endUserWB As Workbook
Dim lastRow As Integer
'Application.ScreenUpdating = False 'Speeds up the routine by not updating the screen.
'IMPORTANT, remember to turn screen updating back on before the routine ends
'***** ENTERING WORKSHEET NAMES *****
'Get the name of the worksheet to be copied from
Sheet_Copy_From = Application.InputBox(Prompt:= _
"Please enter the sheet name you which to copy from", _
Title:="Sheet_Copy_From", Type:=2) 'Type:=2 = text
If Sheet_Copy_From = "False" Then 'If Cancel is clicked on Input Box exit sub
Exit Sub
End If
'*****CHECK TO SEE IF WORKSHEETS EXIST (USES FUNCTION AT VERY TOP)*****
Select Case wsExists(Sheet_Copy_From) 'calling function at very top
Case False
MsgBox "The worksheet named """ & Sheet_Copy_From & """ is either missing" & vbNewLine & _
"or spelt incorrectly" & vbNewLine & vbNewLine & _
"Please rectify and then run this procedure again" & vbNewLine & vbNewLine & _
"Select OK to exit", _
vbInformation, ""
Exit Sub
End Select
Set destWS = ActiveWorkbook.Sheets(Sheet_Copy_From)
'array of sheet names to test for
colNames = Array("SID", "First Name", "Last Name", "xyz", "Telephone Number", "Department")
'Get the name of the worksheet to pasted into
newSheet = Application.InputBox(Prompt:= _
"Please enter the sheet name you which to paste in", _
Title:="New File", Type:=2) 'Type:=2 = text
If newSheet = "False" Then 'If Cancel is clicked on Input Box exit sub
Exit Sub
End If
Set endUserWB = Workbooks.Add
endUserWB.SaveAs Filename:=newSheet
endUserWB.Sheets(1).Name = "Sheet1"
'endUserWS.Name = "End User"
'Copy Columns 1 by 1
i = 1
For Each col In colNames
On Error GoTo colNotFound
colN = destWS.Rows(1).Find(col, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
lastRow = destWS.Cells(Rows.Count, colN).End(xlUp).Row
'MsgBox "Column for " & colN & " is " & lastRow, vbInformation, ""
'Copy paste Part begins here
If colN <> -1 Then
'destWS.Select
'colVal = destWS.Columns(colN).Select
'Selection.Copy
'endUserWB.ActiveSheet.Columns(i).Select
'endUserWB.ActiveSheet.PasteSpecial Paste:=xlPasteValues
'endUserWB.Sheets(1).Range(Cells(2, i), Cells(lastRow, i)).Value = destWS.Range(Cells(2, colN), Cells(lastRow, colN))
destWS.Range(2, lastRow).Copy
endUserWB.Worksheets("Sheet1").Range(2).PasteSpecial (xlPasteValues)
End If
i = i + 1
Next col
Application.CutCopyMode = False 'Clears the clipboard
'MsgBox "Column """ & colN & """ is Found",vbInformation , ""
colNotFound:
colN = -1
Resume Next
End Sub
What is wrong with code? Any other method to copy? I followed the answer at Copy from one workbook and paste into another as well. But it also gives blank sheet.
If I understood it right try changing this part of your code:
destWS.Range(2, lastRow).Copy
endUserWB.Worksheets("Sheet1").Range(2).PasteSpecial (xlPasteValues)
by:
destWS.Activate
destWS.Range(Cells(2, colN), Cells(lastRow, colN)).Copy
endUserWB.Activate
endUserWB.Worksheets("Sheet1").Cells(2, colN).PasteSpecial (xlPasteValues)