I have a problem with a VBA-based hyperlink in Excel 2016. I want to add a "Navigation" sheet in front of all other sheets but I have an issue with "=HYPERLINK". My code is the following:
Dim wbBook As workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
wbBook.Sheets.Add(Before:=Worksheets(1)).Name = "Navigation"
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & ";" & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
The problem I have is that when I add an "=" in front of HYPERLINK, the error "Anwendungs- oder objektorientierter Fehler" (application or object oriented error) pops up. If I run the macro without the "=", the program works but I manually have to add the equation sign in the navigation sheet.
Cheers in advance!
Since you are already using VBA, why not the VBA capability of Adding Hyperlinks (with .Hyperlinks.Add).
You can read about it more on MSDN
I reduced a the use of ActiveSheet, and Activate.
Code
Option Explicit
Sub TestHyperlink()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
Set wsActive = wbBook.Sheets.Add(Before:=Worksheets(1))
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
With wsSheet
.Hyperlinks.Add Anchor:=Worksheets("Navigation").Range("A" & lnRow), _
Address:="", SubAddress:="'" & .Name & "'!" & .Range("A" & lnRow).Address, _
TextToDisplay:="#" & .Name
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
End Sub
Try using a comma to separate the parameters of the formula instead of a semicolon. I think forcing formulae into cells like this ignores localisation.
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & "," & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With
Related
I am making a tool in excel VBA to bulk create some kind of invoices to each customer. We are making LIVE streams and selling kids clothing, then we write all our orders to excel sheet. Example:
orders list
Then we have to sort all those orders by customer (there are many of them) and create some kind of invoice for each customer. Example: "invoice template"
I use this code to bulk create those and download as pdfs.
Sub Create_PDF_Files()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dsh As Worksheet
Dim tsh As Worksheet
Dim setting_Sh As Worksheet
Set dsh = ThisWorkbook.Sheets("uzsakymai")
Set tsh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim i As Integer
Dim File_Name As String
For i = 2 To dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
Application.StatusBar = i - 1 & "/" & dsh.Range("A" & Application.Rows.Count).End(xlUp).Row - 1
tsh.Range("D1").Value = dsh.Range("C" & i).Value
tsh.Range("A4").Value = dsh.Range("B" & i).Value
tsh.Range("B4").Value = dsh.Range("A" & i).Value & " - " & dsh.Range("E" & i).Value
tsh.Range("P4").Value = dsh.Range("D" & i).Value
File_Name = dsh.Range("A" & i).Value & "(" & dsh.Range("C" & i).Value & "-" & dsh.Range("D" & i).Value & ").pdf"
tsh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Next i
Application.StatusBar = ""
MsgBox "Done"
End Sub
But what it does is creating invoice for each item.
EXAMPLE
Any ideas how could I make it work for me as I want it to work?
---EDIT---
After ALeXceL answer, it seems to have some bugs. I changed my code to his code, and I see some progress in creating this program, but what it does, is it shows first item correctly, but all the other items are appearing starting on A24 cell. EXAMPLE
---EDIT---
IT WORKS!!!
Assuming that "uzsakymai" is "orders", the 'data sheet' (dsh) and "lapukas" is the 'template' sheet (tsh), I did these changes, added some counters, in order to the logic flows the right way:
Important: before put this code to run you MUST classify the 'orders' table (dsh, or "uzsakymai") first by Name, then, by Size (as you wish, according to the images posted)
Option Explicit
Sub Create_PDF_Files()
Dim Orders_sh As Worksheet
Dim Template_sh As Worksheet
Dim setting_Sh As Worksheet
Dim oCell As Excel.Range
Dim strKey_TheName As String
Dim lngTemplate_A As Long
Dim lngSumOfItems As Long
Dim dblSumOfValues As Double
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Orders_sh = ThisWorkbook.Sheets("uzsakymai")
Set Template_sh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim lngI As Long
Dim File_Name As String
'At this point, the Orders_sh worksheet should already have its fields properly sorted/ordered. (Name, then Size)
lngI = 2
Application.StatusBar = lngI - 1 & "/" & Orders_sh.Range("A11").End(xlUp).Row - 1 'a maximum of 10 items can be written here!
Set oCell = Orders_sh.Range("A" & lngI) ' the initial cell
Do
strKey_TheName = UCase(Orders_sh.Range("C" & lngI).Value)
lngSumOfItems = 0
dblSumOfValues = 0
Do
Template_sh.Range("D1").Value = Orders_sh.Range("C" & lngI).Value
lngTemplate_A = IIf(lngSumOfItems = 0, 4, Template_sh.Range("A10").End(xlUp).Offset(1, 0).Row)
Template_sh.Range("A" & lngTemplate_A).Value = Orders_sh.Range("B" & lngI).Value
Template_sh.Range("B" & lngTemplate_A).Value = Orders_sh.Range("A" & lngI).Value & " - " & Orders_sh.Range("E" & lngI).Value
Template_sh.Range("P" & lngTemplate_A).Value = Orders_sh.Range("D" & lngI).Value
lngSumOfItems = lngSumOfItems + 1
dblSumOfValues = dblSumOfValues + Orders_sh.Range("D" & lngI).Value
File_Name = lngSumOfItems & "(" & Orders_sh.Range("C" & lngI).Value & "-" & VBA.Round(dblSumOfValues, 0) & ").pdf"
lngI = lngI + 1
Set oCell = oCell.Offset(1, 0)
Loop Until strKey_TheName <> UCase(oCell.Offset(0, 2).Value)
Template_sh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Template_sh.Range("D1").Value = ""
Template_sh.Range("A4:P10").ClearContents
Loop Until Len(oCell.Value) = 0
Application.StatusBar = ""
MsgBox "Done"
End Sub
I know this code is a mess but it's been at least working with no errors for weeks. The directories of all the files in question exist.
'''
Sub NEW_PO()
'''''''''''''''''''''''''''''''''''Declare Variables''''''''''''''''''''''''''''''''''''''''''''
Dim disc As String
Dim New_Data_Column As Long 'last date ordered column (number)
Dim NewPO_num As String 'New_Data_Column - 10 (needs leading "0" for single digits)
Dim Job_Num As String '= C2
Dim Cost_Code As String '= Active sheet name
Dim lastCol As String 'last date ordered column (Letter)
Dim sht As Worksheet
Dim lastRow As Long 'last row of description column
Set sht = ActiveSheet
''''''''''''''''''''''Find last row and column(letter)''''''''''''''''''''''''''''''''''''''''''
New_Data_Column = Cells(8, Columns.count).End(xlToLeft).Column
lastCol = Split(Columns(Range("A8").End(xlToRight).Column).Address(, False), ":")(1)
lastRow = sht.Cells(sht.Rows.count, 3).End(xlUp).Row
'''''''''''''''''''''''''''''Check for Data'''''''''''''''''''''''''''''''''''''''''''''''''''''
If WorksheetFunction.CountA(Range(lastCol & "11:" & lastCol & lastRow)) = 0 Then
MsgBox "Error! Please enter data to continue."
Exit Sub
ElseIf WorksheetFunction.CountA(Range(lastCol & "10")) = 0 Then
MsgBox "Error! Please enter date to continue."
Range(lastCol & "10").Select
Exit Sub
Else
''''''''''''''''''''''''''''''''Propmt for description of PO''''''''''''''''''''''''''''''''''''
disc = InputBox("Please enter a description for this Purchase Order.", "New Purchase Order")
If disc = "" Then
MsgBox "You Must Enter A Description!"
Exit Sub
End If
''''''''''''''''''''''''''''''''''Set Cost Code''''''''''''''''''''''''''''''''''''''''''''''''
Cost_Code = sht.name
'''''''''''''''''''''''''''''''''Set Job Number''''''''''''''''''''''''''''''''''''''''''''''''
Job_Num = sht.Cells(2, 4).Text 'as text to keep formatting
'''''''''''''''''''''''''''''Set New Purchase Order Number'''''''''''''''''''''''''''''''''''''
sht.Range("A4").Value = sht.Range("A4").Value + 1
If sht.Range("A4").Value < 10 Then
NewPO_num = "0" & sht.Range("A4").Value
Else
NewPO_num = sht.Range("A4").Value
End If
''''''''''''Open PO Template and save as PO number & Copy PO to S/R Log''''''''''''''''''''
Dim sPath As String
sPath = Application.ThisWorkbook.path
Dim i As Integer
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastPO_row As Long
Dim lastSR_row As Long
Dim wkb3 As Workbook
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Application.ScreenUpdating = False
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sPath & "\1 CONSTRUCTION\Purchase Orders\Purchase Order Template.xlsm")
Set wkb3 = Workbooks.Open(sPath & "\1 CONSTRUCTION\RECEIVED MATERIALS\SR Log.xlsx")
Set sht1 = wkb1.Sheets(Cost_Code)
Set sht2 = wkb2.Sheets("Sheet1")
Set sht3 = wkb3.Sheets("Sheet1")
Set sht4 = wkb2.Sheets("Job Addresses")
'''
This is where the error is occurring. Normally it would save the template as specified with no problems. I have deleted the code and written it in notepad and pasted it back into excel and it still gives an error. I've tried on multiple computers with the same result. I even uninstalled and reinstalled office and still not working.
'''
wkb2.SaveAs (sPath & "\1 CONSTRUCTION\Purchase Orders\" & Cost_Code & "\" & Job_Num & "-" & NewPO_num
& "-" & Cost_Code & " " & disc & ".xlsm")
wkb3.SaveAs (sPath & "\1 CONSTRUCTION\RECEIVED MATERIALS\" & Cost_Code & "\" & Job_Num & "-" &
NewPO_num & "-" & Cost_Code & " " & disc & ".xlsx")
sht2.name = Job_Num & "-" & NewPO_num & "-" & Cost_Code & " " & disc
lastPO_row = sht2.Cells(sht.Rows.count, 3).End(xlUp).Row + 1
lastSR_row = sht3.Cells(sht.Rows.count, 1).End(xlUp).Row + 1
''''''''''''Copy relevant entries to PO sheet and Shipping/Receiving Log'''''''''''''''''''
For i = 11 To lastRow
If sht1.Cells(i, New_Data_Column).Value <> "" Then
sht1.Range(lastCol & i).Copy
sht2.Range("A" & lastPO_row).PasteSpecial xlPasteValues
sht3.Range("D" & lastSR_row).PasteSpecial xlPasteValues
sht1.Range("B" & i & ":C" & i).Copy
sht2.Range("B" & lastPO_row & ":C" & lastPO_row).PasteSpecial xlPasteValues
sht3.Range("A" & lastSR_row & ":B" & lastSR_row).PasteSpecial xlPasteValues
lastPO_row = lastPO_row + 1
lastSR_row = lastSR_row + 1
End If
Next
sht2.Range("E6").Value = wkb1.Sheets("PM Dashboard").Range("O3").Value
sht2.Range("E7").Value = Job_Num & "-" & NewPO_num & "-" & Cost_Code
sht2.Range("E8").Value = Dashboard.Sheets("PM Dashboard").Range("Y2").Value
'add this job's address to list of addresses on PO
sht4.Range("A7").Value = wkb1.Sheets("PM Dashboard").Range("O3").Value & vbNewLine _
& wkb1.Sheets("PM Dashboard").Range("AP3").Value & vbNewLine & wkb1.Sheets("PM
Dashboard").Range("AP4").Value
wkb2.Save
sht3.Range("C1").Value = Job_Num & "-" & NewPO_num & "-" & Cost_Code & " " & disc
wkb3.Save
wkb3.Close
'''''''''''''''''''''copy over last column and hide previous'''''''''''''''''''''
sht1.Columns(New_Data_Column).Copy
sht1.Columns(New_Data_Column + 1).PasteSpecial Paste:=xlPasteFormats
sht1.Range(lastCol & "8:" & lastCol & "9").Copy
sht1.Range(lastCol & "8:" & lastCol & "9").Offset(0, 1).PasteSpecial Paste:=xlPasteValues
Call HIDE
wkb1.Save
Application.ScreenUpdating = True
End If
End Sub
'''
I cannot seem to get this line of code working:
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=INDEX('" & cNameAndPath & BET_ws.Cells(errCell.Row,
2).Value & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cNameAndPath &
BET_ws.Cells(errCell.Row, 2).Value & "'!R2C2:R400C2,0),MATCH(RC3,'" & cNameAndPath
& BET_ws.Cells(errCell.Row, 2).Value & "'!R1C3:R1C200,0))"
Next errCell
I keep getting an object undefined error. Is it a problem with my R1C1 notation or is it an issue with BET_ws.Cells(errCell.Row,2).Value statement? In Column B the tab name needed for my INDEX reference is in the RC2 location. Not sure how to correct the issue. cNameAndPath is defined and is pulling the value I want. Another formula is running in the adjacent range with no problem.
Here is most of the code if it helps:
Sub BetConverter()
Dim wbkTarget As Workbook
Dim fNameAndPath As Variant
Dim cNameAndPath As Variant
Dim cFileName As String
Dim cFilePath As String
Dim BET_ws As Worksheet
Dim shtTarget As Worksheet
Dim ws As Worksheet
Dim lrow As Long 'last row variable
Dim lcol As Long 'last column variable
Dim lastrow As Long
Dim i As Integer
Dim cwbTarget As Workbook
Dim errCell As Range
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete summary tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("BET Consolidated").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Macro")).Name = "BET Consolidated" 'create new tab
Set BET_ws = ThisWorkbook.Sheets("BET Consolidated")
MsgBox ("Please Select the Bid Entry Tool to be Consolidated in the following File Dialog Box.")
fNameAndPath = Application.GetOpenFilename(Title:="Select Bid Entry Tool to be Consolidated")
If fNameAndPath = False Then Exit Sub
Set wbkTarget = Workbooks.Open(fNameAndPath)
MsgBox ("Please Select the MDB for Comparison in the following File Dialog Box.")
cNameAndPath = Application.GetOpenFilename(Title:="Select the MDB for Comparison")
If cNameAndPath = False Then Exit Sub
Set cwbTarget = Workbooks.Open(cNameAndPath)
cFileName = Mid$(cNameAndPath, InStrRev(cNameAndPath, "\") + 1)
cFilePath = Left$(cNameAndPath, InStrRev(cNameAndPath, "\"))
Do While shtTarget Is Nothing
For Each ws In wbkTarget.Sheets
If ws.Name Like "*H*" Then
Set shtTarget = ws
End If
Next ws
Loop
lrow = shtTarget.Cells(Rows.Count, 11).End(xlUp).Row
With shtTarget.Range("K2:K" & lrow)
BET_ws.Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("J2:J" & lrow)
BET_ws.Range("B1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("O2:O" & lrow)
BET_ws.Range("C1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("P2:P" & lrow)
BET_ws.Range("D1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
i = 0
For Each ws In wbkTarget.Worksheets
If ws.Name Like "*H*" Then
Set shtTarget = ws
lastrow = shtTarget.Cells(shtTarget.Rows.Count, 27).End(xlUp).Row
With shtTarget.Range("AA1:AA" & lastrow)
BET_ws.Range(Range("D1").Offset(0, 1 + i).Address).Resize(.Rows.Count, .Columns.Count) = .Value
End With
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=INDEX('" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R2C2:R400C2,0),MATCH(RC3,'" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R1C3:R1C200,0))"
Next errCell
For Each errCell In BET_ws.Range("F5:F" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""MATCH"",""DOES NOT MATCH"")"
Next errCell
i = i + 3
End If
Next ws
Also tried like this:
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
tName = BET_ws.Cells(errCell.Row, 2).Value
errCell.FormulaR1C1 = "=INDEX('" & cFilePath & "[" & cFileName & "]" & tName & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cFilePath & "[" & cFileName & "]" & tName & "'!R2C2:R400C2,0),MATCH(RC3,'" & cFilePath & "[" & cFileName & "]" & tName & "'!R1C3:R1C200,0))"
Next errCell
I have written this code and it has worked until now.
I have put two AutoFilter to pull certain rows. How do I amend the code to copy and paste visible rows?
I tried
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy'
which copies the cells but then I get an error. Object required
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
MyDir = "C:\Users\eldri\OneDrive\Desktop\New folder (2)\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
'opens excel
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False,
Password:=CalcPassword(MyFile))
Set TempSH = TempWB.Worksheets(1)
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Worksheets("Data").Range("A4").AutoFilter Field:=3, Criteria1:="AMS"
Worksheets("Data").Range("A4").AutoFilter Field:=4, Criteria1:="XNE"
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row)
NewMasterLine = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & (NewMasterLine + TempRng.Rows.Count))
MasterRange.Value = TempRng.Value
'Debug.Print "Imported File: " & MyFile & ", Imported Range: " & TempRng.Address & ", Destination Range: " & MasterRange.Address
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You cannot use Set and .Copy in one line.
First you need to set your range of visible cells:
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
Then you need to test if there were visible cells found and if so you can copy them:
If Not TempRng Is Nothing Then
TempRng.Copy
'all code that relies on the copied range `TempRng` needs to go here
Else
MsgBox "No visible cells found!"
End If
I rewrote the code with the advice from #PEH and it worked - Please find the new code below.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
' Change address to suite
MyDir = "C:\Users\eldri\OneDrive\Desktop\W220Q1\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows wiill start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master worklbook
For Each TempRow In TempRng.Rows
If TempRow.Cells(1, 3).Value = "AMS" And TempRow.Cells(1, 4).Value = "XNE" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
I have checked a lot of different solutions here on stackoverflow, but none of them worked for me.
When I insert a value like "1" everything works, but When I try to insert my formula I always get a runtime error. Does anyone have an explanation? Would be very thankful for any help!
Sub test()
Dim cell As Excel.Range
Dim wsWithSheetNames As Excel.Worksheet
Dim wbToAddSheetsTo As Excel.Workbook
Set wsWithSheetNames = ActiveSheet
Set wbToAddSheetsTo = ActiveWorkbook
For wsname = 1 To 254
For Each cell In wsWithSheetNames.Range("A" & wsname)
With wbToAddSheetsTo
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cell.Value
wsname2 = cell.Value
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next cell
Worksheets("Sheet1").Range("B1", "B1735").Copy
Worksheets(wsname2).Range("A2")
(HERE IS THE PROBLEM!)Worksheets(wsname2).Range("B2:AGR1736").FormulaLocal =
"=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & CHr(34) & wsname2 & Chr(34) & "!$A$1:$D$2000,0,
(COLUMN(A2)*4-4)),4,0),"")"
Next wsname
End Sub
EDIT: changed the line to:
Worksheets(wsname2).Range("B2:AGR1736").FormulaLocal =
"=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & wsname2 & "!$A$1:$D$2000,0,
(COLUMN(A2)*4-4)),4,0)," & Chr(34) & Chr(34) & ")"
If I dont write the "=" the code works just fine, why is it not working with the "="?
I think you need to declare wsname and wsname 2, so the full code would be like this:
Sub test()
Dim cell As Excel.Range
Dim wsWithSheetNames As Excel.Worksheet
Dim wbToAddSheetsTo As Excel.Workbook
Dim wsname As Integer
Dim wsname2 As String
Set wsWithSheetNames = ActiveSheet
Set wbToAddSheetsTo = ActiveWorkbook
For wsname = 1 To 254
For Each cell In wsWithSheetNames.Range("A" & wsname)
With wbToAddSheetsTo
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cell.Value
wsname2 = cell.Value
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next cell
Worksheets("Sheet1").Range("B1", "B1735").Copy Worksheets(wsname2).Range("A2")
'Worksheets(wsname2).Range("B2:AGR1736").FormulaLocal =
'"=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & CHr(34) & wsname2 & Chr(34) & "!$A$1:$D$2000,0,
'(COLUMN(A2)*4-4)),4,0),"")"
Worksheets(wsname2).Range("B2:AGR1736") = "=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & wsname2 & "!$A$1:$D$2000,0," & "(COLUMN(A2)*4-4)),4,0)," & Chr(34) & Chr(34) & ")"
Next wsname
End Sub
Hope this help.