I'm trying to create an excel that will multiply and divide the values inserted in the cells. The choice to multiply or divide the cells is up to the user, they can choose between 1000 or 1,000,000.
The first problem is:
I wanted only cells that have values in them from a particular column (From column J to W) to be multiplied or divided, but I couldn't find a way to do it, so I just selected a range that will be big enough so it will include all the cells a user will enter values in.
The problem is that I don't want it to multiply or divide empty cells and generate a "0" value. (I want it to stay empty = That the function won't run on empty cells)
The second problem I'm trying to solve is that the VBA function will save the file as a CSV with the name given in Cell "G2".
I'm also interested that the function will save the file in a specific location. This specific location will be inside a folder that the VBA function will create, the name of the folder will be the name in Cell "G3".
Also, I want it to check if there is already a folder by that name in that specific location, and if it's true it will not open a new folder, and save the file in that folder.
The water flow I'm aiming for:
Click on Save as CSV ----> Function checks if there is a folder name similar to the one in cell "G3" ---> If there is a folder with the same name ---> Function saves the file as CSV with the name attributed in cell "G2" ----> If there isn't such folder name, it will open a new folder with the name in "G3", and will save the file as CSV with the name attributed in cell "G2".
Sub Multi1000()
Dim rngdata As Range
Set rngdata = ThisWorkbook.Worksheets("Sheet1").Range("J8:W200")
rngdata = Evaluate(rngdata.Address & "*1000")
End Sub
Sub Multi1000000()
Dim rngdata As Range
Set rngdata = ThisWorkbook.Worksheets("Sheet1").Range("J8:W200")
rngdata = Evaluate(rngdata.Address & "*1000000")
End Sub
Sub Divi1000000()
Dim rngdata As Range
Set rngdata = ThisWorkbook.Worksheets("Sheet1").Range("J8:W200")
rngdata = Evaluate(rngdata.Address & "/1000000")
End Sub
Sub Divi1000()
Dim rngdata As Range
Set rngdata = ThisWorkbook.Worksheets("Sheet1").Range("J8:W200")
rngdata = Evaluate(rngdata.Address & "/1000")
End Sub
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Rows("1:6").Select
Selection.Delete Shift:=xlUp
With Range("J2:W200")
.NumberFormat = "General"
.Value = .Value
End With
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Related
I'm looking for assistance regarding how to write a VBA command that allows me to copy a range of cells from different workbooks onto one master sheet. Let me explain further.
Everyday I receive a new excel document from my clients named based on the date it was uploaded ie. September 18, 2018 file would be called A20180918.
Once i've received a week's worth of excel files (A20180918-A20180921), I then have to copy certain information from the original uploaded file to a master tracking sheet.
So, my hurdle is such that each time I record my actions into a macro, the code includes the file name which then creates a subscript error when it's run on the next day's file.
So here's an example below of the code I have this far:
Sub CopyRange()
CopyRange Macro
'This is the line of the code that's causing problems given it's a specified workbook name
'and when I try to open tomorrow's workbook i'll run into the subscript error.
Windows("A20180914.xls").Activate
Range("A2:B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Master Sheet.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Thank you!
Here's two solutions. One to scan an Directory for files, and the other to select files. I see they've both been suggested in the comments already. :p
Sub Test()
' If you want to scan an "unprocessed files" directory
'Call ScanDir("C:\Test\")
' If you want to select files to process
Call SelectFiles
End Sub
Private Sub ScanDir(ByVal DirPath As String)
Dim oCurFile As String
oCurFile = Dir(DirPath)
Do While oCurFile <> ""
' Add the work to the file here
' Filename: DirPath & oCurFile
oCurFile = Dir()
Loop
End Sub
Private Sub SelectFiles()
Dim oFileDialog As FileDialog
Set oFileDialog = Application.FileDialog(msoFileDialogFilePicker)
oFileDialog.AllowMultiSelect = True
If oFileDialog.Show = -1 Then
Dim oFile As Variant
For Each oFile In oFileDialog.SelectedItems
' Add the work to the file here
' Filename: oFile
Next
End If
End Sub
By the looks of it you have all the workbooks open when you run the code - there are ways to have the code open each workbook in a certain folder, or ask the user to select them.
While writing this other answers have given the code for selecting files from folders.
Each workbook in the Excel Application is held in a collection of workbooks. The good thing about collections is you can step through them without know the specifics before you get there.
The code below will print the name of each workbook you have open into the immediate window. Note - these are in the same instance of Excel. If you open Excel a second time then any workbooks in that application will be in a different collection.
You don't really need the Application but I left it in to make things a bit clearer.
Sub Test()
Dim bk As Workbook
For Each bk In Application.Workbooks
Debug.Print bk.Name
Next bk
End Sub
This is the full code - note that nothing is Selected.
Sub Test()
Dim bk As Workbook
Dim Master As Workbook
Dim LastCell As Range
Set Master = Workbooks("Master Sheet.xlsm")
For Each bk In Application.Workbooks
'Checks the middle part of the file name - should be a number.
'Better ways to check the file name are available.
If IsNumeric(Mid(bk.Name, 3, 8)) Then
'Copy date from Sheet1. It's assumed each row in
'column B is populated and figures out the last cell from there.
With bk.Worksheets("Sheet1")
Set LastCell = .Cells(.Rows.Count, 2).End(xlUp)
.Range("A1", LastCell).Copy
End With
'Pastes the results to Sheet1 in the Master workbook.
'The last cell containing data in column A is found and
'then offset by 1 row.
With Master.Worksheets("Sheet1")
.Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
Next bk
End Sub
This will do it, you just need to supply the sheet name and ranges where noted:
Sub copyRange()
'File system variables
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim myDir As String
Dim Mask As String
'Workbook variables
Dim wb As Workbook
Dim sh As Worksheet
myDir = "C:\Users\Guest\Desktop" 'Insert the path where your incoming files are stored.
Mask = "*.xl??" 'This makes it so it only looks at Excel files.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getFolder(myDir)
For Each objFile In objFolder.Files
If LCase(objFile.Name) Like LCase(Mask) Then
Set wb = Workbooks.Open(myDir & "\" & objFile.Name, , True) 'This is set to open in read only, to avoid issues with the file already being open
'The ranges you are copying/pasting are vague, supply the sheet names and ranges below
'Get Copy range with dynamic number of rows.
With wb.Sheets("Sheet1").Range("A2:B2") '<---- Specify Sheet/Range
Set copyRange = .Resize(.End(xlDown).Row, 2)
End With
'Get next available row in paste range.
With ThisWorkbook.Sheets("Sheet1").Range("G:H") '<---- Specify Sheet/Range
Set pasteRange = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
copyRange.Copy pasteRange
wb.Close False
End If
Next objFile
End Sub
I have a master workbook that I have that already looks through all the files in a folder. However, one of the tabs needs to look through all the tabs in a different selected workbook "Data". The workbook has roughly 30 worksheets, and I need to loop through each worksheet except "Investments" and "Funds". If it makes it easier these are the first two tabs in the workbook. I then need to copy cell F9 in each worksheet, paste it into a different workbook "Master" cell "C4", go back to the same worksheet in the "data" workbook and copy range "C16:C136" and paste that into cell "E4" of the "master" workbook. Then it would need to loop to the next worksheet in the "data" workbook and continue the loop. For each new worksheet, I need it to paste one row lower in the "master" file. i.e. the second worksheet would paste in "C5" and "E5".
If it makes it easier I can split this up into two macros. And Just paste all the data from the worksheets into a new blank sheet in the data work book and then I can have another one to copy all of that over into the "master" workbook once done.
Thanks in Advance
Sub ImportInformation()
WorksheetLoop
End Sub
Function WorksheetLoop()
Dim wb As Workbook
Dim ws As Worksheet
Dim foundCell As Range
Dim strFind As String
Dim fRow, fCol As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' This allows you to use excel functions by typing wf.<function name>
Set wf = WorksheetFunction
'Set the name of your output file, I assume its fixed in the Master File
‘Please note that I am running this out of the master file and I want it all in the Noi tab
Set NOI = ThisWorkbook.Worksheets("NOI")
'Retrieve Target File Path From User
Set FilePicker = Application.FileDialog(msoFileDialogFolderPicker)
‘This only selects a folder, however I would like it to select a SPECIFIC FILE
With FilePicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
' initialize the starting cell for the output file
pasterow = 4
‘I need this to be referring to the file that I choose
For Each ws In wb.Worksheets
If ws.Name <> "Funds" And ws.Name <> "Investments" Then
Next ws
Wb.Worksheets.Range.("F9").Copy
NOI.Range("C" & pasterow).PasteSpecial xlPasteValues, Transpose:=False
'Get find String
strFind = NOI.Range("C2").Value
'Find string in Row 16 of each row of current ACTIVE worksheet
Set foundCell = wb.Worksheets.Range("A16:IT16").Find(strFind, LookIn:=xlValues)
'If match cell is found
If Not foundCell Is Nothing Then
'Get row and column
fRow = foundCell.Row
fCol = foundCell.Column
'Copy data from active data worksheet “data” and copy over 300 columns (15 years).
‘ This is needed to find what specific date to start at. This portion works, I just need it to loop through each worksheet.
wb.Worksheets.active.Range(Cells(fRow + 1, fCol).Address & ":" & Cells(fRow + 1, fCol + 299).Address).Copy
'Paste in NOI tab of mater portfolio
NOI.Range("E" & pasterow).PasteSpecial xlPasteValues, Transpose:=False
wb.Application.CutCopyMode = False
Else
Call MsgBox("Try Again!” vbExclamation, "Finding String")
End If
Next Ws
wb.Close SaveChanges:=False
End Function
Please show us your first attempt. Feel free to put in comments like
' I need this to do XXXX here, but I don't know how
Here are a some hints:
To loop through all sheets in a workbook, use:
For each aSheet in MyWorkbook.Sheets
To skip some specific sheets, say:
If aSheet.Name <> "Investments" And aSheet.Name <> "Funds"
To copy from aSheet to MasterSheet, start by setting the initial destinations:
set rSource = aSheet.range("F9")
set rDestin = MasterSheet.range("C4")
Then in your loop you do the copy:
rDestin.Value = rSource.Value
...and set up the next set of locations
set rSource = rSource.offset(1,0)
set rDestin = rDestin.offset(1,0)
Does that help?
EDIT: Briefly looking at your version, I think this part won't work:
If ws.Name <> "Funds" And ws.Name <> "Investments" Then
Next ws
Don't you want to delete that last line?
EDIT 2: You use this a lot:
wb.Worksheets.<something>
But that does not refer to a specific worksheet. You want to use "ws", like this:
ws.Range("F9")
BIG EDIT:
Step through this version carefully and see how it works:
Sub ImportInformation()
WorksheetLoop
End Sub
Function WorksheetLoop()
Dim wb As Workbook
Dim ws As Worksheet
Dim foundCell As Range
Dim strFind As String
Dim fRow, fCol As Integer
'*** Adding Dims:
Dim wf, FilePicker
Dim NOI As Worksheet
Dim myPath As String
Dim PasteRow As Long
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' This allows you to use excel functions by typing wf.<function name>
Set wf = WorksheetFunction
'Set the name of your output file, I assume its fixed in the Master File
'Please note that I am running this out of the master file and I want it all in the Noi tab
Set NOI = ThisWorkbook.Worksheets("NOI")
'Retrieve Target File Path From User
' Set FilePicker = Application.FileDialog(msoFileDialogFolderPicker)
'This only selects a folder, however I would like it to select a SPECIFIC FILE
' With FilePicker
' .Title = "Select A Target Folder"
' .AllowMultiSelect = False
' If .Show <> -1 Then GoTo NextCode
' myPath = .SelectedItems(1) & "\"
' End With
Dim WorkbookName As Variant
' This runs the "Open" dialog box for user to choose a file
WorkbookName = Application.GetOpenFilename( _
FileFilter:="Excel Workbooks, *.xl*", Title:="Open Workbook")
Set wb = Workbooks.Open(WorkbookName)
' initialize the starting cell for the output file
PasteRow = 4
'I need this to be referring to the file that I choose
For Each ws In wb.Worksheets
If ws.Name <> "Funds" And ws.Name <> "Investments" Then
' **** Leave this out: Next ws
ws.Range("F9").Copy '<--- You mean this, not wb.Worksheets.Range.("F9").Copy
NOI.Range("C" & PasteRow).PasteSpecial xlPasteValues, Transpose:=False
'Get find String
strFind = NOI.Range("C2").Value
'Find string in Row 16 of each row of current ACTIVE worksheet
Set foundCell = ws.Range("A16:IT16").Find(strFind, LookIn:=xlValues)
'If match cell is found
If Not foundCell Is Nothing Then
'Get row and column
fRow = foundCell.Row
fCol = foundCell.Column
'Copy data from active data worksheet “data” and copy over 300 columns (15 years).
' This is needed to find what specific date to start at. This portion works, I just need it to loop through each worksheet.
ws.Range(Cells(fRow + 1, fCol).Address & ":" & Cells(fRow + 1, fCol + 299).Address).Copy
'Paste in NOI tab of mater portfolio
NOI.Range("E" & PasteRow).PasteSpecial xlPasteValues, Transpose:=False
'*** Move PasteRow down by one
PasteRow = PasteRow + 1
wb.Application.CutCopyMode = False
Else
Call MsgBox("Try Again!", vbExclamation, "Finding String")
End If
End If
Next ws
wb.Close SaveChanges:=False
End Function
Currently I have a workbook that loops through workbooks in the same folder as it, end copies data from specific cells back to the master workbook. If I want to change to cells from where the code copies cells, I’ll have to change this value in the code.
However, I have co-workers who needs to use this sheet aswell, to collect data from other workbooks. – So I need to make this use friendly.
What I want to do, is to have the code read a cell value in the masterworkbook, and use this cell value as the cell that it copies from.
Example:
If I type “B3” in the masterworkbook cell A1 and run the macro, the macro will copy data from the originsheet B3, into the first cell of the masterworkbook. Does anyone have any idear how to accomplish this?
Or something like:
.Cells(1).Value = originsheet.Range(Range("CellValue from destinationsheet A1").Value).Value
Here is the code I use:
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range
Set destsheet = ThisWorkbook.Worksheets("Sheet1")
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
If Fname <> ThisWorkbook.Name Then
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets(1)
With RngDest
.Cells(1).Value = originsheet.Range(Range("A1").Value).Value
.Cells(2).Value = originsheet.Range(Range("A2").Value).Value
.Cells(3).Value = originsheet.Range(Range("A3").Value).Value
.Cells(4).Value = originsheet.Range(Range("A4").Value).Value
.Cells(5).Value = originsheet.Range(Range("A5").Value).Value
End With
wkbkorigin.Close SaveChanges:=False 'close current file
Set RngDest = RngDest.Offset(1, 0)
End If
Fname = Dir() 'get next file
Loop
End Sub
And a picture of what i mean, in case im unclear:
enter image description here
I am sorry, but I believe you haven't made yourself clear. However, you may be trying to get something like this (correct me if I'm wrong):
destinationsheet.Range("A1") = originsheet.Range(destinationsheet.Range("A1"))
This will make the value in your Master Workbook be substituted by the content in cell address of the other worksheet.
I have the below code.
Very simply it asks the user to select multiple excel workbooks and then will copy and paste data from those workbooks to the current work book.
1.
I would like to add the functionality, whereby instead of the user selecting the excel workbooks. The excel workbooks will be selected in that their names are listed on the current excel sheet.
For example - Select excel workbooks in specified folder whose names are listed in A1:A5.
I would like to perform automatic processing on the data before it is copied into the current work book.
For example if workbook name = 100.xlsx then multiply selection by 15.
See my current code
Sub SUM_BalanceSheet()
Application.ScreenUpdating = False
'FileNames is array of file names, file is for loop, wb is for the open file within loop
'PasteSheet is the sheet where we'll paste all this information
'lastCol will find the last column of PasteSheet, where we want to paste our values
Dim FileNames
Dim file
Dim wb As Workbook
Dim PasteSheet As Worksheet
Dim lastCol As Long
Set PasteSheet = ActiveSheet
lastCol = PasteSheet.Cells(1, Columns.Count).End(xlToLeft).Column
'Build the array of FileNames to pull data from
FileNames = Application.GetOpenFilename(filefilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=True)
'If user clicks cancel, exit sub rather than throw an error
If Not IsArray(FileNames) Then Exit Sub
'Loop through selected files, put file name in row 1, paste P18:P22 as values
'below each file's filename. Paste in successive columns
For Each file In FileNames
Set wb = Workbooks.Open(file, UpdateLinks:=0)
PasteSheet.Cells(1, lastCol + 1) = wb.Name
wb.Sheets("Page 1").Range("L14:L98").Copy
PasteSheet.Cells(2, lastCol + 1).PasteSpecial Paste:=xlPasteValues
wb.Close SaveChanges:=False
lastCol = lastCol + 1
Next
'If it was a blank sheet then data will start pasting in column B, and we don't
'want a blank column A, so delete it if it's blank
If Cells(1, 1) = "" Then Cells(1, 1).EntireColumn.Delete shift:=xlLeft
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This is a frame that needs fine-tuning, but you can get the idea:
Dim i&, wbName$
Dim rng As Excel.Range
Dim wb, wb1 As Excel.Workbook
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("A1")
For i = 0 To 14
wbName = CStr(rng.Offset(i, 0).Value)
On Error Resume Next 'Disable error handling. We will check whether wb is nothing later
wb1 = Application.Workbooks.Open(wbName, False)
On Error GoTo ErrorHandler
If Not IsNothing(wb1) Then
'Copy-paste here
If wb1.Name = "100" Then 'any condition(s)
'Multiply, divide, or whatever
End If
End If
Next
ErrorHandler:
MsgBox "Error " & Err.Description
'Add additional error handling
Try not to use ActiveSheet and ActiveWorkbook without absolute need. Use ThisWorkbook, dedicated Workbook object, and named sheet Workbook.Sheets("Name") or Workbook.Sheets(index) instead.
Alternatively instead of disabling error checking you can do it and fail if a file is missing.
My work is regarding formating 100 of files everyday. though i have a macro desined for the purpose but i have to run the macro on each and every file one after saving previous.
my question is how can i be able to run my macro on these opened workbooks in one step. As i save one it would run on other one in the queue.
Put the following macro in a "BASE" workbook as Passerby mentioned
Sub SO()
Dim macroList As Object
Dim workbookName As String
Dim wbFullPath
Dim macroName As String
Dim currentWb As Workbook
Dim masterWb As Workbook ' the Excel file you are calling this procedure from
Dim useWbList As Boolean
Dim height As Long, i As Long
Dim dataArray As Variant
useWbList = False ' DEFINE which input method
Set macroList = CreateObject("Scripting.Dictionary")
If useWbList Then
' you can also from the dictionary from 2 columns of an excel file , probably better for management
With masterWb.Worksheets("Sheet1") '<~~ change Sheet1 to the sheet name storing the data
height = .Cells(.Rows.Count, 1).End(xlUp).Row ' Assume data in column A,B, starting from row 1
If height > 1 Then
ReDim dataArray(1 To height, 1 To 2)
dataArray = .Range(.Cells(1, 1), .Cells(height, 2)).Value
For i = 1 To height
macroList.Add dataArray(i, 1), dataArray(i, 2)
Next i
Else
'height = 1 case
macroList.Add .Cells(1, 1).Value, .Cells(1, 2).Value
End If
End With
Else
' ENTER THE FULl PATH in 1st agrument below, Macro Name in 2nd argument
' Remember to make sure the macro is PUBLIC, try to put them in Module inside of Sheets'
macroList.Add "C:\Users\wangCL\Desktop\Book1.xlsm", "ThisWorkbook.testing"
'macroList.Add "FULL PATH", "MACRO NAME"
'macroList.Add "FULL PATH", "MACRO NAME"
'macroList.Add "FULL PATH", "MACRO NAME"
End If
Application.DisplayAlerts = False
For Each wbFullPath In macroList.keys
On Error GoTo 0
macroName = macroList.Item(workbookName)
workbookName = Mid(wbFullPath, InStrRev(wbFullPath, "\") + 1)
Err.Clear
On Error Resume Next
Set currentWb = Nothing
Set currentWb = Workbooks(workbookName) ' see if the workbook is already open
If Err.Number <> 0 Then
' open the workbook if workbook NOT opened
Set currentWb = Workbooks.Open(workbookName, ReadOnly:=True)
End If
On Error GoTo 0
' run the macro
Application.Run workbookName & "!" & macroList.Item(wbFullPath)
'close the workbook after running the macro
currentWb.Close saveChanges:=False
Set currentWb = Nothing
Next wbFullPath
End Sub
Hope it helps and please let me know if there's anything unclear
I have got my solve using below code.
Sub OpenAllWorkbooksnew()
Set destWB = ActiveWorkbook
Dim DestCell As Range
Dim cwb As Workbook
For Each cwb In Workbooks
**Call donemovementReport**
ActiveWorkbook.Close True
ActiveWorkbook.Close False
Next cwb
End Sub