Im intending to conduct a VBA macro which returns the cell value of C34 of the file referenced by path which has the sheet names as presented in myHeadings.
Sub Test()
Dim myHeadings() As String
Dim i As Long
Dim path As String
path = "C:\pathtofile\file.xlsx"
Dim currentWb As Workbook
Set currentWb = ActiveWorkbook
Dim openWb As Workbook
Set openWb = Workbooks.Open(path)
Dim openWs As Worksheet
myHeadings = Split("Januari,Februari,Mars", ",")
For i = 0 To UBound(myHeadings)
Set openWs = openWb.Sheets(myHeadings(i))
currentWb.Sheets("Indata").Range("AA" & 73+Application.Match (myHeadings(i),Array,False)).Value = openWs.Range("C34").Value
Next i
End Sub
This however gives the error message: Automation Error -2147221080 (800401a8) at the code snippet:
currentWb.Sheets("Indata").Range("AA73+Application.Match (i,Array,False)").Value = openWs.Range("C34").Value
I'm new to VBA and am yet to create a macro actually runable, so the cause may be trivial. From googling I'm yet to find a solution to this specific problematic.
EDITED some code to remove "Array" and updated t
I think you want this:
currentWb.Sheets("Indata").Range("AA" & 73 + Application.Match(i,Array,False)) = openWs.Range("C34")
If the result of
Application.Match(i,Array,False)
is equal to 1, you want to make AA74 to equal whatever is in openws.Range("C34"), right?
'&' is a concatentation character, so what we are saying above is that we take "AA" then calculate 73 + 1 and concatenate it to the end. The bit you were missing is escaping the text after the "AA" to do the numerical calculation.
EDIT:-
After reading Aiken's comments above, I believe your answer should be to remove the Match function entirely:
currentWb.Sheets("Indata").Range("AA" & 73 + i + 1).Value = openWs.Range("C34").Value
Related
This code line says = Nothing?
Set SrcDataRange = Src.Range("A13:P" & LastRow)
It`s in a Vlookup code shown below.
If there is a simpler way to write a Vlookup code please tell me?
I used the same code as before but different workbooks and it worked??
Private Sub Up_Date_Prices_Click()
Application.ScreenUpdating = False
Dim SrcOpen As Workbook
Dim Des As Workbook
Dim JCM As Worksheet
Dim Src As Worksheet
Dim FilePath As String
Dim Filename As String
Dim PLDataRange As Range
Dim LastRow As Long
FilePath = "\\TGS-SRV01\Share\ShopFloor\PRODUCTION\PURCHASING\"
Filename = "TGS Group Inventory Sheet - Main.xlsx"
Set SrcOpen = Workbooks.Open(FilePath & Filename)
Set Src = SrcOpen.Worksheets("Part List")
LastRow = Src.Cells(Src.Rows.Count, "A").End(xlUp).row
Set SrcDataRange = Src.Range("A13:P" & LastRow)
Windows("TGS Group Inventory Sheet - Main.xlsx").Visible = True
Set Des = Workbooks("Automated Cardworker.xlsm")
Set JCM = Des.Worksheets("Job Card Master")
JCM.Range("O15").Value = Application.WorksheetFunction.VLookup(JCM.Range("D15"), SrcDataRange, 16, 0)
Application.DisplayAlerts = False
SrcOpen.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This row I think is wrong
LastRow = Src.Cells(PL.Rows.Count, "A").End(xlUp).row
PL is not set anywhere. Also the variable PLDataRange is never used. I guess you intend to set that somewhere?
I have Option Explicit turned on as default and it means you can never use undeclared variables
Let me know if this is helpful, thanks
I think this is answered here How to error handle 1004 Error with WorksheetFunction.VLookup?
In summary, if there is no match VLookup throws an error - if it is not this then check your last row: O15 your output is only 2 rows below A13 the first anchor to your input range so check that columnP doesnt extend below row 14.
Some observations, JCM.Range("D15") might be better as JCM.Range("D15").value and also the final parameter is actually a boolean so might be better as False rather than zero. They may or may not have any effects here but it may be helpful to get into that habit: Little mistakes like these have cost me hours debugging in the past :)
i am new to VBA. I got this code but when it runs, it shows this error message :
Wrong number of argument or invalid property assignment.
This is my code when i copied it from somewhere and editing myself :
Sub cl_macro2()
cl_macro2 macro '
Dim Concur As Worksheet, SunAccCode As Worksheet
Dim ConcurLastRow As Long, SunAccCodeLastRow As Long, x As Long
Dim SunAccCodeRng As Range
Set Concur = ThisWorkbook.Worksheets("Concur")
Set SunAccCode = ThisWorkbook.Worksheets("SunAccCode")
ConcurLastRow = Concur.Range("I" & Rows.Count).End(xlUp).Row
SunAccCodeLastRow = SunAccCode.Range("A" & Rows.Count).End(xlUp).Row
Set SunAccCodeRng = SunAccCode.Range("A1:C" & SunAccCodeLastRow)
For x = 2 To ConcurLastRow
On Error Resume Next
Concur.Range("J" & x).Value = Application.WorksheetFunction.VLookup(Concur.Range("I" & x).Value, SunAccCodeRng, 3, 0)
Next x
End Sub
The second line of your code reads:
cl_macro2 macro '
This appears to be a (meaningless) comment, but without the apostrophe at the beginning of the line telling VBA not to execute it.
What's actually happening is that VBA is trying to execute this line as if it were code. As written, it means the sub is trying to call itself - and pass an argument (variable) called "macro". But since the sub doesn't take any arguments, you get an error.
For a comment, you need to insert a ' like this:
' cl_macro2 macro '
Otherwise, just delete the whole line.
I have a macro that is to be used inside a macro I found on internet.
The second macro runs through all Excel files inside a folder:
Sub RunOnAllFilesInFolder()
Dim folderName As String, eApp As Excel.Application, fileName As String
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
'Select folder in which all files are stored
fDialog.Title = "Select a folder"
fDialog.InitialFileName = currWb.Path
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
'Create a separate Excel process that is invisibile
Set eApp = New Excel.Application: eApp.Visible = False
'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
fileName = Dir(folderName & "\*.*")
Do While fileName <> ""
'Update status bar to indicate progress
Application.StatusBar = "Processing " & folderName & "\" & fileName
Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)
'...
'YOUR CODE HERE
'...
wb.Close SaveChanges:=False 'Close opened worbook w/o saving, change as needed
Debug.Print "Processed " & folderName & "\" & fileName
fileName = Dir()
Loop
eApp.Quit
Set eApp = Nothing
'Clear statusbar and notify of macro completion
Application.StatusBar = ""
MsgBox "Completed executing macro on all workbooks"
End Sub
I made a macro that, based on three named cells in a file, finds the ranges and change the style of some other ranges.
Not all Excel files have all three named cells, so I need the code to work when the range is not valid.
I tried to use error handlers but I received the following error:
"Loop without Do"
I tried IF and else for when the range does not exist and also found errors.
My code:
Dim test As Worksheet
Dim rOutstandingR As Range
Dim rAdditionalDueR As Range
Dim rFollowingR As Range
Dim rOutstandingBorderR As Range
Dim rAdditionalDueBorderR As Range
Dim rFollowingBorderR As Range
Dim ORow As Long
Dim OCol As Long
Dim ARow As Long
Dim ACol As Long
Dim FRow As Long
Dim FCol As Long
Dim OutstandingTopBorderRange As Range
Dim OutstandingBottomBorderRange As Range
Dim OutstandingRightBorderRange As Range
Dim AdditionalDueTopBorderRange As Range
Dim AdditionalDueBottomRange As Range
Dim AdditinalDueRightBorderRange As Range
Dim FollowingTopBorderRange As Range
Dim FollowingBottomBorderRange As Range
Dim FollowingRightBorderRange As Range
Dim OutstandingTextRange As Range
Dim AdditionalDueTextRange As Range
Dim FollowingTextRange
With Range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
Set rOutstandingR = ActiveSheet.Range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
‘more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
Set rAdditionalDueR = ActiveSheet.Range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
‘more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
Set rFollowingR = ActiveSheet.Range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
‘more code in which I change format of cells based on range
As you can imagine by the amount of ranges, there is a lot of code in between but it's only based on the three major ranges for the named cells "Outstanding", "AdditionalDue" and "Following".
I need that all the codes between ranges work and if the first range doesn't exist goes to validate then next and do the changes of format, etcetera.
I tried to put some error handlers (resume labels) but I wasn't able to fix it when I used the code above within the first macro due to the loop through all the files.
How can I put the error handlers so I could use this macro inside the one that runs over a folder of files.
There are two ways to handle this, however with the snippets provided it's not straightforward to test what you're working on. You may want to consider separating your code into multiple subs/functions.
This solution should be clean assuming that you want some type of handling code to run:
With range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
On Error GoTo OutstandingError
Set rOutstandingR = ActiveSheet.range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
OutstandingResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
On Error GoTo AdditionalDueError
Set rAdditionalDueR = ActiveSheet.range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
AdditionalDueResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
On Error GoTo FollowingError
Set rFollowingR = ActiveSheet.range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
FollowingResume:
'more code in which I change format of cells based on range
GoTo Complete
OutstandingError:
'Error handling code here
Resume OutstandingResume
AdditionalDueError:
'Error handling code here
Resume AdditionalDueResume
FollowingError:
'Error handling code here
Resume FollowingResume
Complete:
This solution just bypasses the block entirely without any handling code:
With range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
On Error GoTo OutstandingResume
Set rOutstandingR = ActiveSheet.range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
OutstandingResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
On Error GoTo AdditionalDueResume
Set rAdditionalDueR = ActiveSheet.range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
AdditionalDueResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
On Error GoTo FollowingResume
Set rFollowingR = ActiveSheet.range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
FollowingResume:
'more code in which I change format of cells based on range
If you'd like to go in a different direction, here is a function that returns a boolean for whether or not a named range exists. Using this you could refactor this to use conditionals instead of relying on error checking and line jumps.
Private Function BET_RangeNameExists(nname) As Boolean
Dim n As Name
BET_RangeNameExists = False
For Each n In ActiveWorkbook.Names
If UCase(n.Name) = UCase(nname) Then
BET_RangeNameExists = True
Exit Function
End If
Next n
End Function
Taken from https://bettersolutions.com/excel/named-ranges/vba-named-range-exists.htm
When I try to write something from the method given by EPPlus i.e. It comes up with two error messages
We have found a problem with some content
Excel completed file level validation and repair. some parts of this workbook may have been repaired or discarded.
Excel opens successfully but, with error messages and one more thing excel I'm writing is already written that means it is a template.
Dim consh As ExcelWorksheet
'Dim excelStream As New MemoryStream()
'excelStream.Write(excel, 0, excel.Length)
Dim exlpck As New ExcelPackage(excel)
If exlpck.Workbook.Worksheets(cellExcelTabName) Is Nothing Then
consh = exlpck.Workbook.Worksheets.Add(cellExcelTabName)
Else
consh = exlpck.Workbook.Worksheets(cellExcelTabName)
End If
Dim start = consh.Dimension.Start
Dim [end] = consh.Dimension.[End]
For row As Integer = 4 To [end].Row
' Row by row...
For col As Integer = 18 To 35
' ... Cell by cell...
' This got me the actual value I needed.
Dim cellValue As String = consh.Cells(row, col).Text
Dim cellAddress = consh.Cells(row, col).Address
Dim i = 0
For Each mText In textToFind
If cellValue.Contains(mText) Then
consh.Cells(cellAddress).Value = cellValue.Replace(mText, "")[enter image description here][1]
consh.Cells(cellAddress).Style.Fill.PatternType = ExcelFillStyle.Solid
consh.Cells(cellAddress).Style.Fill.BackgroundColor.SetColor(color(mText.Substring(1, 1) - 1))
i = i + 1
End If
Next
Next
Next
'Dim exlpck1 As New ExcelPackage(e)
exlpck.Save()
Dim s = New MemoryStream(exlpck.GetAsByteArray())
Return s
As stated here ("I get an error that Excel has found unreadable content ..."), the EPPlus Package does not validate formulas and number formats. You might want to check there for hints.
I found the fix for my code
exlpck.Save()
to be Replaced by
exlpck.SaveAs(ms)
And it worked :)
I have a sheet that has names, SSNs and 4 columns filled with the following values: S, MB, B.
For said columns I wish to replace S with the number 4, MB with the number 3 and B with the number 2.
Sub replace()
Dim str1, str2, str3, filename, pathname As String
Dim i As Integer
str1 = "MB"
str2 = "B"
str3 = "S"
filename = "p"
pathname = ActiveWorkbook.Path
i = 1
Do While filename <> ""
Set wb = Workbooks.Open(pathname & filename + i)
DoWork wb
wb.Close SaveChanges:=True
filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
End With
End Sub
In the function DoWork, how do I create a loop to replace each of the values?
I mostly agree with Michael--to learn the most, you should get started on your own, and come back with more specific questions. However, I am looking to reach 50 rep so I will pander to you. But do please try to go through the code and understand it.
Your name suggests you are a programmer, so the concepts we make use of should be familiar. I like to work from the inside out, so here goes:
here are my variables:
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
At the core, you'll want a select case statement to read each cell and decide what the new value should be. Then you will assign the new value to the cell:
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Around that you'll want a for each loop to define the current cell and iterate through all the cells in the range you specify for that particular worksheet:
set rRange = wsSheet.Range("C2:E5000") 'Customize to your range
for each c in rRange.Cells
'...
next
Next level up is the for next loop to iterate through all the worksheets in the current file:
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
'...
NextOne:
Next i
The if then statement at the top prevents an error if there are fewer than 30 worksheets in a workbook. If the number of sheets per file varies then this will be useful, if the number is fixed, just adjust the loop to stop and the right spot. Of course, this assumes your workbooks have information on multiple sheets. If not skip the loop altogether.
I'm sure many will criticize my use of goto, but since VBA loops lack a continue command, this is the workaround I employ.
Around that you'll want another iterator to loop through your multiple files. Assuming they are all in the same folder, you can use the Dir() function to grab the file names one-by-one. You give it the file path and (optionally) the file type, and it will return the first file name it finds that meets your cirteria. Run it again and it returns the second file name, etc. Assign that to a string variable, then use the file path plus the file name to open the workbook. Use a do loop to keep going until runs out of files:
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
'...
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
Now Put it all together:
Sub ReplaceLetterCodewithNumberCode()
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
Application.ScreenUpdating = False
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
Set rRange = wsSheet.Cells("C2:E5000") 'Customize to your range. Assumes the range will be the same
For Each c In rRange.Cells
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Next
NextOne:
Next i
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
'Clean up
Set wbBook = Nothing
Set wsSheet = Nothing
Set rRange = Nothing
Set c = Nothing
Application.ScreenUpdating = True
End Sub
I'll provide a high level explanation of this; implementation will be up to you. You'll start with a crawler to open all of these files one by one (a google search should help you with this).
I'm not exactly sure how your sheets are organized but the general idea is to open each sheet and perform the action, so you'll need a list of filenames/paths or do it sequentially. Then once inside the file assuming the structure is the same of each you'll grab the column and input the appropriate value then save and close the file.
If you're looking for how to open the VBA editor go to options and enable the Developer tab.
This is a good beginner project and while you may struggle you'll learn a lot in the process.