I am quite new in VBA and wrote a subroutine that copy-paste cells from one document into another one. Being more precise, I am working in document 1 where I have names of several product (all in column "A"). For these product, I need to look up certain variables (e.g. sales) in a second document.
The subroutine is doing the job quite nicely, but I want to use it as a funcion, i.e. I want to call the sub by typing in a cell "=functionname(productname)".
I am grateful for any helpful comments!
Best, Andreas
Sub copy_paste_data()
Dim strVerweis As String
Dim Spalte
Dim Zeile
Dim findezelle1 As Range
Dim findezelle2 As Range
Dim Variable
Dim Produkt
'Variable I need to copy from dokument 2
Variable = "frequency"
'Produkt I need to copy data from document 2
Produkt = Cells(ActiveCell.Row, 1)
'path, file and shhet of document 2
Const strPfad = "C:\Users\Desktop\test\"
Const strDatei = "Bezugsdok.xlsx"
Const strBlatt = "post_test"
'open ducument 2
Workbooks.Open strPfad & strDatei
Worksheets(strBlatt).Select
Set findezelle = ActiveSheet.Cells.Find(Variable)
Spalte = Split(findezelle.Address, "$")(1)
Set findezelle2 = ActiveSheet.Cells.Find(Produkt)
Zeile = Split(findezelle2.Address, "$")(2)
'copy cell that I need
strZelle = Spalte & Zeile 'Zelladresse
strVerweis = "'" & strPfad & "[" & strDatei & "]" & strBlatt & "'!" & strZelle
'close document 2
Workbooks(strDatei).Close savechanges:=False
With ActiveCell
.Formula = "=IF(" & strVerweis & "="""",""""," & strVerweis & ")"
.Value = .Value
End With
End Sub
Here is an example to create a function that brings just the first 3 letters of a cell:
Public Function FirstThree(Cell As Range) As String
FirstThree = Left(Cell.Text, 3)
End Function
And using this in a Excel worksheet would be like:
=FirstThree(b1)
If the sub works fine and you just want to make it easier to call you can add a hotkey to execute the Macro. In the developer tab click on Macros then Options. You can then add a shortcut key (Crtl + "the key you want" it can be a shortcut key already used like C, V, S, but you will lose those functions (Copy, Paste Save, Print)
enter image description here
Related
Im going to start by telling what my intention was with this code
In my job we have to open every sales order that will be sent in that day and check for the itens to be shipped manually.
Since its very time consuming i tought in creating a worksheet that it will look for the itens in every sales order and copy/paste in my master so i can know what i need to get.
However to my sheet works I had to make a few changes in the Sales order, but now I want to create a error check, that if the file that it was open was an older SO it will tell me its order number so later i can check it.
Also i want to check if by some reason nothing was found in that SO.
Now ill explain what my code does (I have a little knowledge in coding and in excel vba, so please dont judge my ugly script)
Using the value of a cell in a range, it will open the folder and file that matches it's value, then will look for a specific range and for a specific cell value, in this case "Perfil", if this value is found it will copy some cells.
After looking for that file it will open another one and do the same.
However if "Perfil" is not found it wont copy and paste anything and it will just go to the next file.
Public Sub test()
On Error GoTo Errormsg
Dim wbk As Workbook
Dim Fonte As Workbook
Dim Dest As Workbook
Dim Filename As String
Dim FolderName As String
Dim Arquivo As String
Dim Path As String
Dim celula As Range
Dim cll As Range
Dim Inicio As Range
Dim Fim As Range
Dim OffInicio As Range
Dim OffFim As Range
Dim busca As Range
Application.ScreenUpdating = False
Set Dest = Workbooks("testee.xlsm")
Path = 'My file path
lrow = Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).Row
For Each celula In Dest.Worksheets(1).Range("A3:A" & lrow)
Dest.Sheets(1).Activate
Pedido = Cells(celula.Row, 1)
FolderName = Pedido & "*"
Arquivo = "\" & Pedido
Folder = Dir(Path & FolderName, vbDirectory)
Filename = Dir(Path & Folder & Arquivo & "*.xlsx")
Set wbk = Workbooks.Open(Path & Folder & "\" & Filename, 0)
Set Fonte = Workbooks(Filename)
Fonte.Activate
Set Inicio = Fonte.Worksheets(1).Cells.Find(what:="MODO DE FIXAÇÃO DO PRODUTO")
Set Fim = Fonte.Worksheets(1).Cells.Find(what:="OBSERVAÇÕES")
Set OffInicio = Inicio.Offset(1, 0)
Set OffFim = Fim.Offset(-1, 1)
Set busca = Range(OffInicio, OffFim).Columns(5)
Set check = Range(OffInicio, OffFim).Columns(9)
Range(OffInicio, OffFim).Columns(5).Select
Set busca = Selection
For Each cl In busca
tipo = Cells(cl.Row, 5).Value
If tipo = "Perfil" Then
tamanho = Cells(cl.Row, 6).Value
expessura = Cells(cl.Row, 11).Value
cor = Cells(cl.Row, 12).Value
lrow2 = Dest.Sheets(2).Range("D" & Dest.Sheets(2).Rows.Count).End(xlUp).Row
linha = lrow2 + 1
Dest.Sheets(2).Range("D" & linha).Value = Pedido
Dest.Sheets(2).Range("E" & linha).Value = tamanho
Dest.Sheets(2).Range("H" & linha).Value = cor
End If
Next cl
End If
Next celula
Errormsg:
lrow2 = Dest.Sheets(2).Range("D" & Dest.Sheets(2).Rows.Count).End(xlUp).Row
linha = lrow2 + 1
Dest.Sheets(2).Range("D" & linha).Value = Pedido
Dest.Sheets(2).Range("E" & linha).Value = "Pedido com modelo Antigo"
End Sub
I want to know the files that no data has been copied, so I can check manually and see why it wasnt.
To do that i tought in checking if in that file any data has been copied and pasted in my master sheet, if nothing was done it will send a message in a cell telling its number so i can check it later.
Now is my question:
I dont know if is possible to check if anything was pasted from that file, in case is possible, how i do that?
I cant just check if "Perfil" exists because for my sheet works I had to change a few things in the sheets that had the data I needed, and "perfil"is not something that the older version of it had.
Also in my new version "Perfil"is not the only value that the column can have so i cant just check if perfil is not found there.
There are a few ways you can check if anything has changed in the workbook. I'd suggest this method:
In any (new or existing) standard module, add a public variable declaration at or near the top of the module:
Public wksChanged As Boolean
For each worksheet that you want to monitor for changes, open the Worksheet's module by right-clicking the worksheet's tab and clicking View Code:
...and then add this procedure (to each applicable worksheet module):
Private Sub Worksheet_Change(ByVal Target As Range)
wksChanged = True
End Sub
wksChanged will default to False when the workbook is first opened, and will change to True when any cell is changed. You can "reset" it at any time with:
wksChanged = False
Just starting out on VBA, and my code is painfully slow. I have a number of workbooks on a network drive, each with several worksheets. I am trying to fetch data from a number of non-contiguous ranges in each worksheet to a pre-designed worksheet, using the following code:
Private Function GetValue(path, file, sheet, ref)
'retrieve value
'// code
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub UpdateModel1()
sheet = "blah blah"
Application.ScreenUpdating = False
'Outputs
destRow = 31 'destination row
destCol = 6 'destination column
srcRow = 50 'source row
For C = 23 To 31 'loop through source columns
ref = Cells(srcRow, C).Address
Cells(destRow, destCol) = GetValue(path, file, sheet, ref)
destCol = destCol + 1
Next C
Application.ScreenUpdating = True
End Sub
However, using a nested for loop in the sub procedure takes way too long. Any suggestions on how to improve this code? PS: this is an amateur's code, and I am just looking for something that does the work decently.
Here is a working example of what you are trying to do:
Sub TestGetSheetValue()
MsgBox GetSheetValue("N:\Tax Documents\", "Tax Stuff.xlsx", "Sheet1", "R1C3")
End Sub
Function GetSheetValue(strPath As String, strFile As String, strSheet As String, strCellRef As String)
GetSheetValue = ExecuteExcel4Macro("'" & strPath & "[" & strFile & "]" & strSheet & "'!" & strCellRef)
End Function
Obviously change what you pass into the function for your needs, note the address is R1C1 format.
The strSheet is the sheet name, not the sheet index.
Make sure you have a trailing \ on the path
Finally, try not to use names like file, path and sheet for variable names.
I am trying to use some Parsing i was able to tweak a little. If I use it in straight VBA in excel, it works fine. However, when I use the same code as a module in VB.NET I get the error in the title on the line of code
ws.Range(vTitles).AutoFilter()
(duh!) I am not sure what is going wrong in the conversion, since I am not a hardcore VB.Net programmer, so I am doing a lot of googling, but not finding much that works. Any ideas on how this could be fixed or do I have to abandon the idea of using this snippet in VB.Net?
Here is the code I am using:
'turned strict off or autofilter per http://www.pcreview.co.uk/threads/autofilter-method-of-range-class-failed.3994483/
Option Strict Off
Imports xl = Microsoft.Office.Interop.Excel
Module ParseItems
Public Sub ParseItems(ByRef fileName As String)
'Jerry Beaucaire (4/22/2010)
'Based on selected column, data is filtered to individual workbooks are named for the value plus today's date
Dim wb As xl.Workbook
Dim xlApp As xl.Application
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As xl.Worksheet, MyArr As Object, vTitles As String, SvPath As String
'Set new application and make wb visible
xlApp = New xl.Application
xlApp.Visible = True
'open workbook
wb = xlApp.Workbooks.Open(fileName)
'Sheet with data in it
ws = wb.Sheets("Original Data")
'Path to save files into, remember the final "\"
SvPath = "G:\MC VBA test\"
'Range where titles are across top of data, as string, data MUST have titles in this row, edit to suit your titles locale
vTitles = "A1:L1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = xlApp.InputBox("What column to split data by? " & vbLf & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xl.XlDirection.xlUp).Row
'Speed up macro execution
'Application.ScreenUpdating = False
'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter(Action:=xl.XlFilterAction.xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True)
'Sort the temporary list
ws.Columns("EE:EE").Sort(Key1:=ws.Range("EE2"), Order1:=xl.XlSortOrder.xlAscending, Header:=xl.XlYesNoGuess.xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xl.Constants.xlTopToBottom, DataOption1:=xl.XlSortDataOption.xlSortNormal)
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = xlApp.WorksheetFunction.Transpose(ws.Range("EE2:EE" & ws.Rows.Count).SpecialCells(xl.XlCellType.xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear()
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter()
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter(Field:=vCol, Criteria1:=MyArr(Itm))
ws.Range("A1:A" & LR).EntireRow.Copy()
xlApp.Workbooks.Add()
ws.Range("A1").PasteSpecial(xl.XlPasteType.xlPasteAll)
ws.Cells.Columns.AutoFit()
MyCount = MyCount + ws.Range("A" & ws.Rows.Count).End(xl.XlDirection.xlUp).Row - 1
xlApp.ActiveWorkbook.SaveAs(SvPath & MyArr(Itm), xl.XlFileFormat.xlWorkbookNormal)
'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51 'use for Excel 2007+
xlApp.ActiveWorkbook.Close(False)
ws.Range(vTitles).AutoFilter(Field:=vCol)
Next Itm
'Cleanup
ws.AutoFilterMode = False
MsgBox("Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!")
xlApp.Application.ScreenUpdating = True
End Sub
End Module
Looks like you need to specify at least one optional parameter. Try this:
ws.Range(vTitles).AutoFilter(Field:=1)
I realize this was closed years ago, but I recently ran into this problem and wanted to add to the solution.
This seems to only work when specifically using the first optional Field parameter. I attempted this fix using the optional VisibleDropDown parameter and still got this error.
ws.Range["A1"].AutoFilter(VisibleDropDown: true); Gives error
ws.Range["A1"].AutoFilter(Field: 1); No error
I have an extensive Workbook which exists in multiple versions that contains hundreds of named ranges.
I want to write a macro that transfers user input data entered to certain named ranges from one instance of the book to another.
The named ranges in the book follow a certain convention, for the purposes of this macro i want to copy the values (which are constants) of all named ranges starting with "in_*" and "resetRange_*"
the macro is supposed to:
open the source book (which has mostly the same named ranges defined as the current book)
iterate over all named ranges of the source book and find the ones like "in_*" or "resetRange_*"
copy the values at the named ranges from the source book to the current book (even if the names refer to areas)
my main questions are:
how do i copy correctly? the current implementation does not work
is there a better way to test whether a source name is still present in the current book?
the named ranges in question all are scoped to the workbook.
The issue that the macro runs error free but does not paste any values. the named ranges of the current book remain empty while the source book contains data
´
Public Sub TransferInputDataFromOtherTool()
Dim sourceBook As Workbook
Dim bookPath As Variant
'get source book
bookPath = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If VarType(bookPath) = vbString Then
Set sourceBook = Workbooks.Open(bookPath)
End If
On Error GoTo Cleanup
'#TODO transfer ranges _
resetRange_* _
in_*
'retrieving data
For Each n In sourceBook.Names
On Error Resume Next
rangeName = n.Name
boola = ThisWorkbook.Names(n.Name)
If boola Then
On Error GoTo 0
If rangeName Like "in_*" _
or rangeName like "resetRange_*" Then
'check for allow edit
On Error Resume Next
sourceBook.Activate
source_value = n.refersToRange.Value
ThisWorkbook.Activate
Range(rangeName).Value = source_value
'Debug.Print rangeName, source_value
'Debug.Print Err.Description, Err.source
On Error GoTo 0
End If
' deleting all in_-values
End If
Next n
'#TODO transfer tables
'ExcelHandling.EnableInteractivity
Cleanup:
On Error Resume Next
sourceBook.Close
On Error GoTo 0
End Sub
Here's a code sample to help. Please turn on Option Explicit and define all your VBA variables. See if this works for you:
EDIT: added range check to detect more than one cell in a given range, then to copy each cell
Option Explicit
Sub TransferInputDataFromOtherTool()
Dim srcWB As Workbook
Dim destWB As Workbook
Dim filename As String
Dim definedVariable As Name
Dim singleCell As Range
Dim singleCellLocation As String
'--- the destination book is the currently active workbook from the user's perspective
Set destWB = ThisWorkbook
'--- source book from which to copy the data from - user selected
filename = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If filename = "False" Then
'--- the user selected cancel
Exit Sub
ElseIf filename = destWB.Path & "\" & destWB.Name Then
MsgBox "You can't open the same file that's already active. Select another file.", vbCritical + vbOKOnly
Exit Sub
Else
Set srcWB = Workbooks.Open(filename)
End If
Debug.Print "values coming from " & filename
For Each definedVariable In srcWB.Names
If (definedVariable.Name Like "in_*") Or (definedVariable.Name Like "resetRange_*") Then
'--- if the source/destination range is only a single cell, then
' it's an easy one-to-one copy
Debug.Print definedVariable.Name & " refers to " & definedVariable.RefersTo;
If destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 0 Then
'--- do nothing
ElseIf destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 1 Then
Debug.Print " source value = '" & destWB.Names(definedVariable.Name).RefersToRange.Value & "'";
Debug.Print " overwritten with '" & srcWB.Names(definedVariable.Name).RefersToRange.Value & "'"
destWB.Names(definedVariable.Name).RefersToRange = srcWB.Names(definedVariable.Name).RefersToRange.Value
Else
'--- the source/target range has multiple cells, either contiguous
' or non-contiguous. so loop and copy...
Debug.Print vbTab & "multiple cells in range..."
For Each singleCell In destWB.Names(definedVariable.Name).RefersToRange
singleCellLocation = "'" & singleCell.Parent.Name & "'!" & singleCell.Address
Debug.Print vbTab & " source value = '" & singleCell.Value & "'";
Debug.Print "' overwritten with '" & srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value & "'"
singleCell.Value = srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value
Next singleCell
End If
End If
Next definedVariable
srcWB.Close SaveChanges:=False
Set srcWB = Nothing
Set destWB = Nothing
End Sub
I have a Word document that contains a table with 3 columns. I'm trying to create a macro that will open a pdf file (name stored in columns 2) at the page number in column 3.
I found a macro in Excel that will open it automatically when I select the page number cell, but nothing in Word. Lots of users are using the Word document and don't want to switch to Excel.
Best will be to activate the macro with a keybord shortcut and if in the table, it will open the file at the page specified in the row where the cursor is. If cursor is not in the table, an error could show.
Thanks.
[EDIT]
Here is the code for the Excel macro. Note that the Adobe Reader path and program is store in cell B1 and the file is in cell B2 in this example.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row > 4 And Target.Column = 1 And Target.Value > 0 Then
vAdobe = ActiveSheet.Cells(1, 2)
vDocument = ActiveSheet.Cells(2, 2)
vPage = Target.Value
result = Shell(vAdobe & " /A ""page=" & vPage & """ " & vDocument, vbNormalFocus)
End If
End Sub
Here's one way:
Sub OpenPDF()
Dim aRow As Row
Dim vDocument As String
Dim vPage As String
Dim vAdobe As String
Dim result As Long
vAdobe = <File path to Acrobat.exe here.>
If Selection.Information(wdWithInTable) = True Then
Set aRow = Selection.Range.Rows(1)
vDocument = Trim(Replace(Replace(aRow.Cells(2).Range.Text, "", ""), vbCr, ""))
vPage = Trim(Replace(Replace(aRow.Cells(3).Range.Text, "", ""), vbCr, ""))
result = Shell(vAdobe & " /A ""page=" & vPage & """ " & vDocument, vbNormalFocus)
Else: 'Some error message here.
End If
End Sub
You may need to play with those Replace methods; I found it necessary to remove some table characters that were appearing at the end of any text pulled from the table cell.
Another option that requires setting a reference can be found here: http://www.myengineeringworld.net/2012/07/vba-macro-to-open-pdf-file.html