I want to extract a range from values in cells in excel. with this code i get a error every time, but not when i put the row and column index numbers manually. This is the code:
Sub Checker()
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
Dim folderpath As String
Dim workbookname As String
Dim filepath As String
folderpath = Range("B3").Value
workbookname = Range("B6").Value
filepath = folderpath + workbookname
Workbooks.Open Filename:=filepath
Range("A1").Select
Dim last_cell As Variant
Dim last_column As Variant
Dim last_row As Variant
last_column = Range("B12").Value
last_row = Range("E12").Value
last_cell = Range("B15").Value
Dim rng As Range, cell As Range
Set rng = Range(Cells(1, 1), Cells(last_row, last_column))
For Each cell In rng
If cell.Locked = True Then
Else
cell.Value = "N/P"
End If
Next cell
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
the last column should be "13" and the last row should be "51"
but every time I get error 1004.
the problem is in the set rng
Define your row/column variables as Long and specify a workbook and worksheet for every object that is located in a worksheet.
Option Explicit
Public Sub Checker()
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
Dim folderpath As String
folderpath = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Dim workbookname As String
workbookname = ThisWorkbook.Worksheets("Sheet1").Range("B6").Value
Dim filepath As String
filepath = folderpath & workbookname 'concatenate strings with & not +
Dim OpenedWb As Workbook ' set the opened workbook as a variable so you can reference it later
Set OpenedWb = Workbooks.Open(Filename:=filepath)
Dim ws As Worksheet ' define the worksheet you want to use in that workbook
Set ws = OpenedWb.Worksheets(1) 'select your sheet by tab position or
'Set ws = OpenedWb.Worksheets("Sheet1") 'select your sheet by tab name
Dim last_column As Long
last_column = ws.Range("B12").Value
Dim last_row As Long
last_row = ws.Range("E12").Value
Dim rng As Range,
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(last_row, last_column))
Dim cell As Range
For Each cell In rng
If Not cell.Locked = True Then
cell.Value = "N/P"
End If
Next cell
'OpenedWb.Close SaveChanges:=True 'if you want to close and save
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Note that if you disalbe events, then make sure you use error handling to enable events in any case of error or they will be turned of until you close Excel.
For Example
Public Sub Example()
Application.EnableEvents = False
On Error Goto SAVE_EXIT
' your code here …
Application.EnableEvents = True
On Error Goto 0 ' re-enable error reporting
Exit Sub
SAVE_EXIT: ' in case of error enable events
Application.EnableEvents = True
' and show error message
If Err.Number Then
Err.Raise Err.Number
End If
End Sub
Related
I am trying to create user form (like on picture) from where I would choose 2 excel files and execute Vlookup. I
I try this code but it does not execute Vlookup.
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Option Explicit
Dim FileToOpen1 As Variant
Dim FileToOpen2 As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Private Sub BrowseButton1_Click()
FileToOpen1 = Application.GetOpenFilename(Title:="Browse for your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen1 <> False Then
TextBox1 = FileToOpen1
End If
End Sub
Private Sub BrowseButton2_Click()
FileToOpen2 = Application.GetOpenFilename(Title:="Browse foy your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen2 <> False Then
TextBox2 = FileToOpen2
End If
End Sub
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
On Error Resume Next
rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").row
Price_clm = wb1.Sheets(1).Range("C3").column
rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
wb1.Sheets(1).Cells(Price_row, Price_clm) = Application.WorksheetFunction.VLOOKUP(cl, rng2, 2, False)
Price_row = Price_row + 1
Next cl
End Sub
You are missing two variable definitions:
Dim Price_row As Long
Dim Price_clm As Long
And variables for range need to be assigned with Set
This: Set rng2 = wb2.Sheets(1).Range("A3:C8") instead of this rng2 = wb2.Sheets(1).Range("A3:C8")
Now, vlookup function in vba will throw an error when it doesnt find a value.
A workaround for this will be something like this.
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
Set rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").Row
Price_clm = wb1.Sheets(1).Range("C3").Column
Set rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
On Error Resume Next
vlResult = "" 'Reset variable
vlResult = Application.WorksheetFunction.VLookup(cl, rng2, 2, False) 'Performs vlookup
If Not vlResult = "" Then
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = vlResult
Else
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = "N/A"
End If
Price_row = Price_row + 1
Next cl
End Sub
*Dont forget to add the variable too.
Dim vlResult As String
This script loops through each value within a filtered column with the aim of filtering one by one, copy the data, create a new workbook, paste it and save it.
It it now creating a signle new workbook with all the worksheets, instead of one workbook per worksheet.
Can someone point out how can I mend the code to create one workbook per value filtered?
On the other hand, the workbook is also keeping the original sheet1. I am also looking on how to remove it, but thought it would be importat to let you know.
Sub test()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' -------------------
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
Dim ws As Worksheet
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
Set ws = Workbk.Worksheets(sht)
'change filter column in the following code
last = ws.Cells(Rows.Count, "BR").End(xlUp).Row
With ws
Set rng = .Range("A1:BR" & last)
End With
ws.Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In ws.Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."
End Sub ```
Put the Workbooks.Add line inside the loop.
Option Explicit
Sub test()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsNew As Worksheet
Dim rng As Range, cel As Range
Dim iLastRow As Long, iLastRowBT As Long
Dim folder As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Workbook where VBA code resides
Set wb = ThisWorkbook
Set ws = wb.Sheets("Report")
folder = wb.Path & "\"
With ws
'change filter column in the following code
iLastRow = .Cells(Rows.Count, "BR").End(xlUp).Row
.Range("BT:BT").Clear
.Range("G1:G" & iLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BT1"), Unique:=True
Set rng = .Range("A1:BR" & iLastRow)
iLastRowBT = .Cells(Rows.Count, "BT").End(xlUp).Row
End With
' create workbooks
For Each cel In ws.Range("BT2:BT" & iLastRowBT)
' Open New Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1)
wsNew.Name = cel.Value
' filter and copy data
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=cel.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
' paste and save
wsNew.Paste
wbNew.SaveAs folder & cel.Value & ".xlsx"
wbNew.Close SaveChanges:=False
Next
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox iLastRowBT - 1 & " Workbooks created in " & folder, vbInformation
End Sub
I cannot find the named range or reference that is invalid, according to Excel. I checked my named ranges, including ranges within charts. The excel file contains a macro that creates a report that works fine when launched within the file itself. However, if I call that function from another workbook to run the report that is when I get the error message of invalid references. When going through the reports created both directly and indirectly they seem identical. Setting Application.DisplayAlerts = False does not work.
I tried using the code below from from Allen Wyatt to go through all reference and none refer to outside sheets nor contain any errors.
Sub CheckReferences()
' Check for possible missing or erroneous links in
' formulas and list possible errors in a summary sheet
Dim iSh As Integer
Dim sShName As String
Dim sht As Worksheet
Dim c, sChar As String
Dim rng As Range
Dim i As Integer, j As Integer
Dim wks As Worksheet
Dim sChr As String, addr As String
Dim sFormula As String, scVal As String
Dim lNewRow As Long
Dim vHeaders
vHeaders = Array("Sheet Name", "Cell", "Cell Value", "Formula")
'check if 'Summary' worksheet is in workbook
'and if so, delete it
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Summary" Then
Worksheets(i).Delete
End If
Next i
iSh = Worksheets.Count
'create a new summary sheet
Sheets.Add After:=Sheets(iSh)
Sheets(Sheets.Count).Name = "Summary"
With Sheets("Summary")
Range("A1:D1") = vHeaders
End With
lNewRow = 2
' this will not work if the sheet is protected,
' assume that sheet should not be changed; so ignore it
On Error Resume Next
For i = 1 To iSh
sShName = Worksheets(i).Name
Application.Goto Sheets(sShName).Cells(1, 1)
Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23)
For Each c In rng
addr = c.Address
sFormula = c.Formula
scVal = c.Text
For j = 1 To Len(c.Formula)
sChr = Mid(c.Formula, j, 1)
If sChr = "[" Or sChr = "!" Or _
IsError(c) Then
'write values to summary sheet
With Sheets("Summary")
.Cells(lNewRow, 1) = sShName
.Cells(lNewRow, 2) = addr
.Cells(lNewRow, 3) = scVal
.Cells(lNewRow, 4) = "'" & sFormula
End With
lNewRow = lNewRow + 1
Exit For
End If
Next j
Next c
Next i
' housekeeping
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
' tidy up
Sheets("Summary").Select
Columns("A:D").EntireColumn.AutoFit
Range("A1:D1").Font.Bold = True
Range("A2").Select
End Sub
I'm new to VBA and trying to put together a macro to copy in data from another workbook and then hyperlink values on an existing sheet to the sheets i've copied in based on a string value in a cell. For the most part the script works however i'm getting a type mismatch error. Hoping someone can help identify what i'm doing wrong.
Sub CopyTitleDetailData()
'Copy all sheets from Key New Release Detail sheet, overrides existing sheets, copys in new sheets
Dim wb As Workbook, ws As Worksheet, wbTarget As Workbook, wsTarget As Worksheet
Application.ScreenUpdating = False
Set wb = ActiveWorkbook 'Main workbook
Dim pth As String
pth = wb.Path
Dim titleDetailPth As String
titleDetailPth = Left(pth, InStrRev(pth, "\") - 1)
Dim filePthName As String
filePthName = titleDetailPth & "\Files for Pre-Order Report (Macro & Alteryx)\" & "Key New Release Accounts Details.xlsx"
Set wbTarget = Workbooks.Open(filePthName, UpdateLinks = False, ReadOnly = True)
For Each wsTarget In wbTarget.Worksheets 'A loop for each worksheet in the Key New Release Detail workbook
For Each ws In wb.Worksheets 'A loop for each worksheet in the Pre-Order (i.e. active workbook)
If wsTarget.Name = ws.Name Then 'If the sheet I am importing exists, it will be deleted
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
wsTarget.Copy After:=wb.Sheets(wb.Sheets.Count) 'Copies it into the last sheet
wb.Sheets(wsTarget.Name).Visible = 0 'Hides the copied sheets
Next wsTarget
wbTarget.Close SaveChanges:=False
Application.ScreenUpdating = True
'Loops through a specified column and when a specified value is found, puts a hyperlink in the cell below
Const cWsName As String = "Title Detail"
Const cSearch As String = "Title"
Const cRow1 As Integer = 1
Const cRow2 As Integer = 800
Const cCol As String = "D"
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCell1 As Range
Dim rCell2 As Range
Dim iR As Integer
Dim strText As String
Dim strAddr As String
Set oWb = ActiveWorkbook
Set oWs = oWb.Worksheets(cWsName)
For iR = cRow1 To cRow2
Set rCell1 = oWs.Range(cCol & iR)
Set rCell2 = oWs.Range(cCol & iR + 1)
strText = rCell2.Text 'What's written in the cell.
strAddr = rCell2.Address 'The address e.g. B1, B13 ...
If rCell1 = cSearch Then
If strText <> "" Then
'Anchor is the place where i'm placing the hyperlink.
'SubAddress is where the hyperlink will take you
rCell2.Hyperlinks.Add _
Anchor:=rCell2, _
Address:="", _
SubAddress:="'" & rCell2 & "'!" & "A1", _
TextToDisplay:=strText 'The same text that orginally lived in the cell
Else
'What im doing if the cell is empty (i.e. nothing)
End If
End If
Next
Dim beginRow As Long
Dim endRow As Long
Dim chkCol As Long
Dim rowCnt As Long
Dim rngResult As Range
beginRow = 1
endRow = 800
chkCol = 1
With oWs
.Cells.EntireRow.Hidden = False 'Unhides all rows, remove line if that's not desired
For rowCnt = beginRow To endRow
If .Cells(rowCnt, chkCol) = "X" Then
If rngResult Is Nothing Then
Set rngResult = .Cells(rowCnt, 1)
Else
Set rngResult = Union(rngResult, .Cells(rowCnt, 1))
End If
End If
Next rowCnt
End With
If Not rngResult Is Nothing Then rngResult.EntireRow.Hidden = True
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim oWs As Workbook
Dim targetString As String, targetSheet As Worksheet
Set oWs = ActiveWorkbook
targetString = Cells(Target.Range.Row, Target.Range.Column).Value
Set targetSheet = oWs.Sheets(targetString)
If targetSheet.Visible = False Then
targetSheet.Visible = True
End If
'End on Title Detail Sheet
targetSheet.Select
End Sub
Per this documentation, you have to provide an Address when adding a hyperlink. you seem to be setting Address = ""
https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add
I found this excellent code however I need to adapt it for my purposes.
Firstly I need to open a data workbook that is on our network. The problem I have is that it is likely at times to be open by another user and will offer the option of "read only". How can I get it to accept the read-only option so that I can commence extracting the data.
Secondly it copies using the "=" . How can I change it to copy just the values?
First macro:
Sub test()
'to open another workbook
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Schedule.xls"
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
2nd Macro:
Dim Sh As Worksheet
Dim Newsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Delete the sheet "Summary-Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Summary-Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Summary-Sheet"
Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add
Newsh.Name = "Summary-Sheet"
'The links to the first sheet will start in row 2
RwNum = 1
For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
For Each myCell In Sh.Range("A1,D5:E5,Z10") '<--Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
Next Sh
Newsh.UsedRange.Columns.AutoFit
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
You could always open the workbook as read-only if you are only extracting data.
Instead of using .formula use .value