VBA: Copy data from another workbook, based on cell value of current workbook - vba

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.

Related

Complicated Save function and multiply function VBA

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

using VBA copying data from different files in a folder to master sheet

I have the following code on a master sheet when I press a button it goes through the folder that I want and opens and closes the sheets where it should extract data from.
Here is the code I have for opening and closing the files from the button on the master sheet. I need help to write a code for the space ###CODE GOES HERE in the below code. I have been pulling my hair out.
Public Sub test()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim Wb1 As Workbook, wb2 As Workbook
Path = "\\ttsnas02\user_mdocs$\tdf8273\Documents\Rob\External supplier timesheet\CSV Supplier Main\Inbox folder\" 'CHANGE PATH
Filename = Dir(Path & "*.xl??")
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
'
' ###CODE GOES HERE
'
wbk.Close True
Filename = Dir
Loop
End Sub
Can you please help me write a code in
This code for '###CODE GOES HERE' needs to get the data from the opening sheets rows by checking if there is a value in a specific column. For example, if there is data in L12.Then in the opening sheet, it will copy J8 J9 and L12 in master sheet a2 c2 and e2.
Then in the opening sheet, it checks L13. IF there is value it copies J8 J9 and L13 to a3 c3 and e3.
Then in the opened sheet checks L14...
Until L20
Then the opened workbook is closed and it opens the next workbook in the folder. Checks the same table:if there is data in L12.Then in the opening sheet, it will copy J8 J9 and L12 in master sheet put in the next free row.
This is is supplier timesheet
supplier timesheet
master sheet
This should do what you want. The code is using for both master and opening the first worksheet with index 1. Change the index if needed:
Public Sub test()
Dim wksMaster As Worksheet
Dim wks As Worksheet
Dim rng As Range
Dim i As Integer
Dim wkb As Workbook
Dim Filename As String
Dim Path As String
Dim Wb1 As Workbook, wb2 As Workbook
Path = "\\ttsnas02\user_mdocs$\tdf8273\Documents\Rob\External supplier timesheet\CSV Supplier Main\Inbox folder\" 'CHANGE PATH
Filename = Dir(Path & "*.xl??")
' bind the master worksheet to access it later on
' change index if needed
Set wksMaster = ActiveWorkbook.Worksheets(1) ' or ThisWorkbook
i = 2
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wkb = Workbooks.Open(Path & Filename)
' loop through range in worksheet with index 1 (the first)
' change index if needed
With wkb.Worksheets(1)
For Each rng In .Range("L12:L20")
' if there is a value in the cell
If rng <> vbNullString Then
wksMaster.Range("A" & i) = .Range("J8")
wksMaster.Range("C" & i) = .Range("J9")
wksMaster.Range("E" & i) = rng
' increment i
i = i + 1
End If
Next
End With
wkb.Close True
Filename = Dir
Loop
End Sub

Setting wbkDest.worksheets("xxxxxxx") to Reflect a Range

I have a workbook that generates pages/page names. The worksheet name always reflects a job number. The job number is also always displayed in cell A1.
I want to copy data from another book, and paste it back into this worksheet, but I need to target the page I want to paste the data.
My issue is that I can't say wbkDest.Worksheets("sheet1").
I need to say something like wbk.Dest.Worksheets(Range("a1").value).
So again: Paste in the sheet with the same name as cell A1 in the workbook the macro is triggered from.
sub import()
Dim wbkSrc As Workbook, wbkDest As Workbook
Dim myFile As String
Dim Path As String
Dim emptyRow As Long
Dim wsOrig As Worksheet
Set wsOrig = ThisWorkbook.Worksheets(1)
emptyRow = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbkDest = Workbooks("lathe_project6-1-2017.xlsm")
Path = "G:\FIXTURES\" & Range("A1").Value & "\lists\new folder\"
myFile = Dir(Path & "*.xls??")
Set wbkSrc = Workbooks.Open(Path & myFile)
wbkSrc.Worksheets(1).Range("A1:I100").Copy
wbkDest.Worksheets(wsOrig.Range("A1").Value).Cells(emptyRow, 1).PasteSpecial Paste:=xlPasteValues
wbkSrc.Close
End Sub
This doesn't work:?
Dim wskVariableSheet as worksheet
Set wskVariableSheet = wbkDest.Sheets(Range("a1").Value)
And then just reference to wskVariableSheet.range where you want to paste.

VBA: Import data between two open worksheets (no path)

I open two Workbooks that are part of the a 3D CAD file and have not real path.
Anyway, after I open them manually I want VBA to move, say, A1 from Workbook B To Workbook A.
In order for VBA to know the name of the source, I say the name of Workbook B is stored in B1 of Workbook A
I know how to move data if I have a path but since there is "none", how do I do that? Thank you!
Hope this help.
Dim FrmWorkbook As Workbook
Dim iCount As Integer
'Capture the source workbook
For i = 1 To ThisWorkbook.Application.Workbooks.Count
'change the name of your source Workbook below
If ThisWorkbook.Application.Workbooks(i).Name = "Book1.xlsx" Then
Set FrmWorkbook = ThisWorkbook.Application.Workbooks(i)
Exit For
End If
Next
'option 1: row by row or column by colum. (Column C)
Dim lRow As Long
For lRow = 1 To 100
ThisWorkbook.Sheets(1).Range("C" & lRow).Value = FrmWorkbook.Sheets(1).Range("C" & lRow).Value
Next
'option 2: copy the entire sheet (assuming Sheet1)
With FrmWorkbook.Sheets(1)
.Activate
.Select
.Copy before:=ThisWorkbook.Sheets(1)
End With
Set FrmWorkbook = Nothing
MsgBox "DONE"
After going back and forth i found out that this works too:
Private Sub import_Click()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb2 = ActiveWorkbook
Set ws2 = wb2.Sheets("sheet1")
Set wb1 = Workbooks(ActiveSheet.Range("n2").Value & ".xls")
Set ws1 = wb1.Sheets("input")
ws2.Range("a1") = ws1.Range("f90").Value
End Sub
Thank you for the good ideas

select all non-blank rows and cells using VBA

I'm new to VBA and I've been trying to figure out how to open an input file and copy those contents to a hidden sheet on my workbook, I saw an example on how to do this but the number of rows and columns is static, and I have to use 3 different input files one of them that changes constantly so, although I've been trying to use my intuition on how to do this, I can't seem to find out the answer.
Here's it is:
Sub s()
' Get customer workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
' copy data from customer to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(1)
Dim lastRow As Long
lastRow = sourceSheet.Range("A" & Rows.Count).End(xlUp).Row
Dim lastColumn As Long
lastColumn = sourceSheet.Cells(1, Columns.Count).End(xlToLeft).Column
targetSheet.Range("A1:A" & lastRow).Value = sourceSheet.Range("A1:A" & lastRow).Value
' Close customer workbook
customerWorkbook.Close
End Sub
I'm using EXCEL 2007
I apologize in advance if this is an stupid noob question, but I honestly give up don't know what else to do to make it work.
The problem Is I don't know how to make it select first to last row and first to last cell (non blank both: cells and rows)
Tried this:
targetSheet.Range("A1:A" & lastRow).End(xlUp).Value = sourceSheet.Range("A1:A" & lastRow).End(xlUp).Value
and this targetSheet.Range("A1:A" & lastRow).End(xlRight).Value = sourceSheet.Range("A1:A" & lastRow).End(xlRight).Value
What about something like this:
SourceSheet.UsedRange.Copy TargetSheet.Range("A1")