With below code, no errors are displayed, the read file opens but it seems not data is copied.
I am trying to copy only a number of columns, but it seems nothing is been copied to current workbook.
Any help would be appreciated as I am very new with VBA
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
'stop screen update
Application.ScreenUpdating = False
Dim src As Workbook
Dim sTheSourceFile As String
sTheSourceFile = "C:\Users\grmn\Desktop\testreadfile.xlsx"
Set src = Workbooks.Open(sTheSourceFile, True, True)
Dim iRowsCount As Long
'source of data
With src.Worksheets("Sheet1")
iRowsCount = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count
End With
Dim iCnt As Long
'destination sheet thisWorkbook.sheet("rapport")
For iCnt = 1 To iRowsCount
Worksheets("rapport").Range("A" & iCnt).Formula = src.Worksheets("Sheet1").Range("A" & iCnt).Formula
Worksheets("rapport").Range("F" & iCnt).Formula = src.Worksheets("Sheet1").Range("B" & iCnt).Formula
Next iCnt
'close but not overide source file (src).
src.Close False
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
No worries being new, we all were at some point.
The first part of your code 'source of data doesn't work as intended. iRowsCount is an Integer and not an Array. To make use of an array, as you seemingly tried to do, you should use
Dim iRowsCount(8) As Long
With src.Worksheets("Sheet")
iRowsCount(1) = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count
' ...
End With
' ...
If you use an Integer only the last row will be assigned. So if "AT", for some reason, has 5 rows, iRowsCount will be 5. Nothing else. Not accounting for "AQ" or "AS".
But in your case, Integer/Long would probably suffice if all rows have the exact same count. One assignment would be enough then.
Regarding .Formula - are you really trying to write formulas? Have you tried .value instead?
And, what may be the crux of the matter, try Worksheets("rapport").Save or Worksheets("rapport").SaveAs at the end of your function.
(Haven't tested it on my end so far.)
Additionally, please remember to set Exit Sub (or Exit Function respectively, if a Function) to avoid executing ErrHandler if no error occurs.
(Sorry, I'm new to Stackoverflow, so I can't write comments as of yet.)
(Edit: Thanks for the reminder, #FunThomas, Integer is only -32768 to 32767. Long is 8 bytes.)
Related
Beginner here and I managed to modify a code to extract data from a sheet and copy and paste them to other sheets. Problem is when I click run Macro or the button assigned to the Macro, it is duplicating rows again. Please help me to avoid the duplication.
TIA
Sub UpdateHistory()
Dim wsData As Worksheet, wsCostCode As Worksheet
Dim LastRow As Long, NextRow As Long, i As Long
Dim CostCode As String
Dim Company As String
Dim Invoice As String
Dim Price As Double
Application.ScreenUpdating = False
Set wsData = Sheets("Signed Invoices")
LastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
CostCode = wsData.Range("A" & i).Value
Company = wsData.Range("B" & i).Value
Invoice = wsData.Range("C" & i).Value
Total = wsData.Range("D" & i).Value
If WorksheetExists(CostCode) = True Then
Set wsCostCode = Sheets(CostCode)
NextRow = wsCostCode.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsCostCode.Range("A" & NextRow).Value = CostCode
wsCostCode.Range("B" & NextRow).Value = Company
wsCostCode.Range("C" & NextRow).Value = Invoice
wsCostCode.Range("D" & NextRow).Value = Total
Else
wsData.Range("A1:D1").Copy
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = CostCode
ActiveSheet.Cells(1, 1).PasteSpecial
ActiveSheet.Range("A2").Value = CostCode
ActiveSheet.Range("B2").Value = Company
ActiveSheet.Range("C2").Value = Invoice
ActiveSheet.Range("D2").Value = Total
End If
Next
Application.CutCopyMode = False
Sheets("Signed Invoices").Select
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
When you find that your code isn't doing what you expect, try stepping through it line-by-line and see exactly where and when it goes wrong. You can do this by pressing F8 while your cursor is anywhere in your macro. I also recommend commenting out Application.ScreenUpdating = False until your code is working as expected. Otherwise, following the code's behavior can become difficult when the code is supposed to write things to worksheets.
You've found that your code is duplicating entries. Let's check all places in your macro that write data to the sheet. There is only one place: inside your For i = 2 to LastRow loop. Because you have set up a loop, you are expecting (or at least preparing) for this block of code to run more than once. The next question should be, why is the data not changing between two iterations like you're expecting?
Check that Else block of code. It seems like you copy the headers, add a new sheet, and then use the ActiveSheet to specify which sheet to write the data. Is ActiveSheet the sheet you think it is? (Very easy to verify with line-by-line debugging.) If you really want to use ActiveSheet, make sure the sheet you expect to be active is active with Worksheets(Worksheets.Count).Activate. This will activate the last worksheet, which is where you want to write your data.
Try stepping line-by-line through your code and see if this is correct before modifying your code.
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 have a list of files with the same structure and I want to extract some information from columns A, B, and C and print it to another workbook.
I found a way to do it for a single file, but now I don't understand how can I do it using the list of given files. I tried using collections, but it doesn't work.
Here's what I came up with:
Sub Pulsante1_Click()
Dim FileGeStar As Variant
Dim myCol As Collection
Set myCol = New Collection
myCol.Add "C:\Users\xxx\Desktop\articoli_def.xlsx"
myCol.Add "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx"
For Each FileGeStar In myCol
Workbooks.Open Filename:=FileGeStar
FileGeStar = Application.ActiveWorkbook.Name
Dim Code As String
Dim Description As String
Dim FilePath As String
Dim i As Long
i = 2
While Range("A" & i) <> ""
FilePath = Application.ActiveWorkbook.Path
Code = Trim(Range("A" & i).Value)
Description = Trim(Range("B" & i).Value)
Workbooks("Report.xlsm").Worksheets(1).Range("A" & i).Value = FilePath
Workbooks("Report.xlsm").Worksheets(1).Range("B" & i).Value = Code
Workbooks("Report.xlsm").Worksheets(1).Range("C" & i).Value = Description
i = i + 1
Wend
Next FileGeStar
End Sub
What can I do?
This might look like an overkill, but I hope the code and comment's are self explanatory:
Option Explicit
Sub Pulsante1_Click()
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = ThisWorkbook 'I think report.xlsm is the workbook running the code
'if report.xlsm is not the workbook running the code then change thisworkbook for workbooks("Report.xlsm")
'add as many paths as you need to, another way would be to write them in a sheet and loop through to fill the array
Dim MyPaths As Variant
MyPaths = Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'Declare a workbook variable for the source workbooks
Dim SourceWorkbook As Workbook
'Declare a long variable to loop through your path's array
Dim i As Long
'loop through the start to the end of your array (will increase as the array does)
For i = LBound(MyPaths) To UBound(MyPaths)
Set SourceWorkbook = OpenWorkbook(MyPaths(i)) 'this will set the workbook variable and open it
CopyData SourceWorkbook, DestinationWorkbook 'this will copy the data to your destination workbook
SourceWorkbook.Close , False
Set SourceWorkbook = Nothing
Next i
End Sub
Private Function OpenWorkbook(FullPath As String) As Workbook
Set OpenWorkbook = Workbooks.Open(FullPath, False, True)
End Function
Private Sub CopyData(wbO As Workbook, wbD As Workbook)
'this procedure calculates the last row of your source workbook and loops through all it's data
'later calls the AddDataToMasterWorkbook procedure to paste the data
With wbO.Sheets(1) 'Im assuming your source workbook has the data on sheet1
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim FilePath As String
FilePath = wbO.Path
Dim Code As String
Dim Description As String
Dim C As Range
For Each C In .Range("A2:A" & LastRow) 'this will loop from A2 to the last row with data
Code = Trim(C)
Description = Trim(C.Offset(, 1))
AddDataToMasterWorkbook wbD, FilePath, Code, Description
Next C
End With
End Sub
Private Sub AddDataToMasterWorkbook(wb As Workbook, FilePath As String, Code As String, Description As String)
'This procedure calculates the last row without data and adds the items you need every time
With wb.Sheets(1)
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow) = FilePath
.Range("B" & LastRow) = Code
.Range("C" & LastRow) = Description
End With
End Sub
To loop though files, you can indeed use a collection, or an array, you can also loop through all files in directory with certain extension, or partial file name. Check out DIR function.
Best not to use ActiveWorkbook, better approach would be to set a workbook object like so: Set wb = Workbooks.Open(fullPathToYourWorkbook).
For what you're doing, there's no need to go row by row, much more efficient way would be to copy entire range, not only it's a lot quicker but also it's only 1 line of code; assuming your destination is ThisWorkbook.Sheets(1) and wb object is set: wb.Range("A:C").Copy Destination:=Thisworkbook.Sheets(1).Range("A:C"). If you need to edit copied data (trim or whatever) consider Range Replace method.
However, if you want to go row by row for whatever reason, as BigBen mentioned in the comment - get rid of While loop.
It's a good idea to set Application.ScreenUpdating to False when opening/closing workbooks, then back to True once it's all done. It will prevent user from accidentaly clicking something etc and will make it look like it's not opening any workbook.
Here's my approach (untested) assuming the workbook you want to copy data to is Workbooks("Report.xlsm").Worksheets(1):
Sub Pulsante1_Click()
'set workbook object for the destination workbook
set wb_dest = Workbooks("Report.xlsm").Worksheets(1)
'disable screen updating
Application.ScreenUpdating = False
For Each target_wb In Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'set wb object and open workbook
Set wb = Workbooks.Open(target_wb)
'find last row in this workbooks in columns A:B (whichever is greater)
LastRow = wb.Range("A:B").Find(What:="*", After:=wb.Range("A1"), SearchDirection:=xlPrevious).row
'copy required data
wb.Range("A1:B" & LastRow).Copy Destination:=wb_dest.Range("B1:C" & LastRow)
'fill column A with path to the file
wb_dest.Range("A1:A" & LastRow).Value = wb.Path
'close workbook
wb.Close False
Next
'enable screen updating
Application.ScreenUpdating = True
End Sub
Obviously an array is not the best approach if you have loads of different files, collection would be a lot clearer to read and edit in the future, unless you want to create a dynamic array, but there's no need for that in my opinion. I didn't declare variables or write any error handling, it's a simple code just to point you in the right direction.
If you want to disable workbook events or/and alerts, you can set Application.DisplayAlerts and Application.EnableEvents to False temporarily.
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.
I have recorded an Excel function (Iferror/Vlookup) which I need to modify to inpput variables to make it more dynamic (Allow for columns moving). Below is a brief outline of what I want to do. The First section is the recorded Function and the variables I want to add. The second section is my proposed solution. My problem is I need to drop the function into excel and copy it down over 50,000 rows. So my error handling solution won't work here. Is it possilbe to make the original recorded function dynamic using iferror/Vlookup. Any help appreciated.
Dim Lookup1 As Long
Dim LookupOffset As Long
Dim LRange As Range
Lookup1 = -99
LookupOffset = 28
Set LRange = Column("CU:CV")
With Worksheets("consolidated")
.Cells(2, 99).FormulaR1C1 = _
"=RC[-71]-IFERROR(VLOOKUP(RC[-12],C[-2]:C[-1],2,FALSE),0)"
.Cells(2, 99).Copy Range(.Cells(2, 99), .Cells(glLastRow, 99))
Application.CutCopyMode = False
.Calculate
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Proposed Solution
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Res As Variant
On Error Resume Next
Err.Clear
Res = Application.WorksheetFunction.VLookup(Lookup1 - LookupOffset, LRange, 2, False)
If Err.Number = 0 Then
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Value found by VLookup. Continue normal execution.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Value NOT found by VLookup. Error handling code here.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
Try this one:
Sub LookUpMod()
Dim wSht As Worksheet: Set wSht = ThisWorkbook.Sheets("Consolidated")
With wSht
On Error Resume Next
.Cells(2, 99).Formula = "=XCV34-IFERROR(VLOOKUP(XFC34,$I:$J,2,FALSE),0)"
.Range(Cells(2, 99), Cells(glLastRow, 99)).FillDown
.Calculate
On Error GoTo 0
End With
End Sub
Just noticed, though, that you don't have glLastRow instantiated properly. Let us know if this helps.
EDIT:
As per chat with OP:
Function LookUpMod(Str As Variant, Rng As Range, OffsetToRight As Long)
Application.Volatile
LookUpMod = Rng.Cells.Find(What:=Str).Offset(0, OffsetToRight).Value
End Function
A simple flexible lookup is what is needed.