I'm trying to make a macro that allows the user to select a file (excel file) which then is used to copy down information to the active workbook from that selected file. I don't know how to include the file's variable directory into the code. Anyone got an idea?
Sub Ref()
Dim Path As String
Path = Application.GetOpenFilename
Dim r As Integer
r = 1
For r = 1 To 1000
If Not IsEmpty(Range(Path(Cells(r, 1)))) Then
Cells(r, 1) = Range(Path(Cells(r, 1)))
End If
Next
End Sub
It seems that you have a list of Excel workbooks together with their path(s) in column A. You are going to have to open the workbook if you want to retrieve information from the cell(s) in that workbook.
This generic framework should help you get started on a sub that loops through the values in the active workbook's active worksheet's column A, opens each file listed and transfers the value from A1 to the original workbook's column B.
Sub ref()
Dim wb0 As Workbook, wb1 As Workbook
Dim r As Long, lr As Long
Set wb0 = ActiveWorkbook
With wb0.Sheets("Sheet1")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
If Not IsEmpty(.Cells(r, 1)) Then
Set wb1 = Workbooks.Open(.Cells(r, 1).Value2)
.Cells(r, 2) = wb1.Sheets("Sheet1").Cells(1, 1).Value
wb1.Close False
End If
Next r
End With
End Sub
You will have to expand on that for your own individual situation but I believe you should see the process as you loop through the workbooks listed in column A.
Related
I'm trying to do a VlookUp with two seperate workbooks. The main workbook opens the supporting workbook right at the beginning like this:
Public Sub GetFile()
Dim MySourceSheet As Variant, wb As Workbook
'Opens window to choose file from
MySourceSheet = Application.GetOpenFilename(FileFilter:= _
"Excel Files (*.XLS; *.XLSX), *.XLS; *.XLSX", Title:="Select file to
retrieve data from.")
If MySourceSheet = False Then Exit Sub
Set wb = Workbooks.Open(MySourceSheet)
End Sub
Throughout the module I reference the document a few times, and then there is this part were the error occurs.
Private Sub VlookupToBeReviewed()
Dim LastColumn As Long
Workbooks("09_PR Status Custodians.xlsm").Activate 'change name
'inserts new column
With Sheets("Prio_Custodians")
LastColumn = Cells(2, .Columns.Count).End(xlToLeft).Column 'change row! 'defines last column
For i = LastColumn To LastColumn Step -2 'moves two columns to the left
.Columns(i).Insert
.Columns(i).ColumnWidth = 10
Next
End With
'puts in the date
Cells(3, LastColumn).Value = Date
'sets up the variables for the vlookup
Dim rw As Long, col As Range
Dim twb As Workbook
'sets up the workbooks
Set twb = ThisWorkbook
Set col = Workbooks(MySourceSheet).Sheets("Documents to be reviewed").Range("A:B")
'vlookup function
With twb.Sheets("Sheet1")
For rw = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(rw, LastColumn) = Application.VLookup(.Cells(rw, 2).Value2, col, 2, False)
Next rw
End With
End Sub
Error:
Set col = Workbooks(MySourceSheet).Sheets("Documents to be reviewed").Range("A:B")
Spits out the
Run-time error '9' (Subscript out of range)
However, when I move my courser over MySourceSheet it shows the correct workbook as defined earlier in the module. If I put the name of the workbook manually with the .xls extension, it works all perfectly fine.I tried looking for an answer all over the web but nothing could quite fix it. I'd very much appreciate some help! :)
sorry if this has been asked here many times. I am a beginner in vba excel, so I only have brief idea of how to begin the code. I am using Excel 2013.
I have 2 different workbooks, main and copy.
Row 1 to 4 will be empty.
Row 5 is meant for header/labeling the information it will be providing for both workbooks.
The "main" workbook will be using columns A to DN to store all the data.
If the cell contains "X" - it will copy column A to P, to the workbook "copy". After which, it will go on to the next row to determine the same thing.
If the cell is empty, it will proceed down to the next row to determine the same thing as well.
The code has to be dynamic as new information will be added every 3 months, such as new rows added or the criteria changing from "X" to empty, or empty to "X".
This is the code I have got as of now.
It works but since there are so many columns to check through, I was advised to do another code for this.
Sub copy()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("main").Cells(Rows.Count, "A").End(xlUp).row
lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row
For r = lr To 2 Step -1
If range("Q" & r).Value = "X" Then
Rows(r).copy Destination:=Sheets("copy").range("A" & lr2 + 1)
lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row
End If
Next r
End Sub
For that you will have to declare two workbook variables and two worksheet variables to hold the source and destination workbooks and worksheets reference in the code.
Tweak the following code as per your requirement.
I have added the comments in the code which will help you to understand the flow of the program.
Further, more error handling can be used to make sure the source and destination sheets are found in source and destination workbook respectively.
If required, you can add the error handling as well.
Option Explicit
Sub CopyDatoToAnotherWorkbook()
Dim srcWB As Workbook, destWB As Workbook 'Variables to hold the source and destination workbook
Dim srcWS As Worksheet, destWS As Worksheet 'Variables to hold the source and destination worksheets
Dim FilePath As String 'Variable to hold the full path of the destination workbook including it's name with extension
Dim lr As Long, lr2 As Long, r As Long
Application.ScreenUpdating = False
Set srcWB = ThisWorkbook 'Setting the source workbook
Set srcWS = srcWB.Sheets("main") 'Setting the source worksheet
'Setting the FilePath of the destination workbook
'The below line assumes that the destination file's name is MyFile.xlsx and it is saved at your desktop. Change the path as per your requirement
FilePath = Environ("UserProfile") & "\Desktop\MyFile.xlsx"
'Cheching if the destination file exists, it yes, proceed with the code else EXIT
If Dir(FilePath) = "" Then
MsgBox "The file " & FilePath & " doesn't exist!", vbCritical, "File Not Found!"
Exit Sub
End If
'Finding the last row used in column A on source worksheet
lr = srcWS.Cells(Rows.Count, "A").End(xlUp).Row
'Opening the destination workbook and setting the source workbook
Set destWB = Workbooks.Open(FilePath)
'Setting the destination worksheet
Set destWS = destWB.Sheets("copy")
'Looping through rows on source worksheets
For r = lr To 2 Step -1
'Finding the first empty row in column A on destination worksheet
lr2 = destWS.Cells(Rows.Count, "A").End(xlUp).Row + 1
If srcWS.Range("Q" & r).Value = "X" Then
srcWS.Rows(r).copy Destination:=destWS.Range("A" & lr2 + 1)
End If
Next r
'Closing the destination workbook
destWB.Close True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have about 50 Excel sheets in one folder, on my MacBook - (/Users/myusername/Desktop/Tidy/folder")
I want to perform the following Macro on them all:
Sub SmartCopy()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long
Set s1 = Sheets("s1")
Set s2 = Sheets("s2")
N = s1.Cells(Rows.Count, "Y").End(xlUp).Row
j = 1
For i = 1 To N
If s1.Cells(i, "Y").Value = "No" Then
Else
s1.Cells(i, "Y").EntireRow.Copy s2.Cells(j, 1)
j = j + 1
End If
Next i
End Sub
I am struggling to get the sheets to open, almost like the filepath won't be recognised, also each sheet is named like this:
business-listing-002-w-site.csv
with one tab:
business-listing-002-w-site.csv
So I also need to either 1) rename the sheet each time 2) have the macro just open the only sheet in the workbook.
I want to copy all data from all workbooks into one master. I did try to add my Macro and adapt this one but just can't get it to run at all.
link to another post
You need to define the workbook (file), not just the sheet(tab).
Dim filePath as String
Dim sheetStart as String
Dim count as Integer
Dim sheetEnd as string
Dim thisSheet as Worksheet
Dim wb1 as Workbook
Dim ws1 as Worksheet
filePath = "/Users/myusername/Desktop/Tidy/folder/"
sheetStart = "business-listing-"
sheetEnd = "-w-site"
Set thisSheet as ThisWorkbook.Worksheets("Sheet1")
For count = 1 to 44 'the range of sheets you have
Set wb1 = Workbooks.Open(filePath & sheetStart & format(count, "000") & sheetEnd & ".csv")
Set ws1 = wb1.Worksheets(sheetStart & format(count, "000") & sheetEnd)
'move the ranges you want from ws1 to thisSheet
wb1.close
next count
each time the code loops, it will change the filename being opened and the sheet that it is looking for.
I assume you either know or can find how to copy a range from ws1 to the next available row of thisSheet based on the original code you provided.
edited with improved code based on comments
I'm currently having problems trying to extract cell data and pasting them into a new workbook. To make things clearer here are the steps
Access a specific worksheet ("Report") in all open workbooks (except the one running the macro)
From the worksheet, extract certain cell data (no. of rows and columns are not fixed but they are identical throughout the open workbooks)
Create a new workbook and paste the data there (each workbook will be assigned one row in the sheet, and all data extracted will be on the same sheet)
I'm having problems with my last sub that extracts this cell data and pastes it into a new workbook, here's what I have so far:
Function Extract_Report_Final(wb As Workbook, book As workbook, counter as long)
Dim last_row, last_col As Long
Dim ws As Worksheet
Dim i, j, k As Integer
Dim data() As String
With wb.Sheets("Report") 'for each worksheet in each open workbook
last_row = .Range("C" & .Rows.Count).End(xlUp).Row
last_col = .Cells(last_row, .Columns.Count).End(xlToLeft).Column
'to get the last row and column where the data required will be located
'this is identical throughout the workbooks as is the name of the worksheet
ReDim data(last_col - 1)
'I decided to use an array to store the values as i don't know how else :(
For k = 0 To (last_col - 2)
Select Case k
Case 0: data(k) = .Cells(1, 1).Value
Case 1: data(k) = .Cells(last_row, 3).Value
Case Else: data(k) = .Cells(last_row, k + 2).Value
End Select
Next k
k = 0
'A weak attempt at trying to copy.paste the values onto a new workbook
'I also don't know how to reference a newly created workbook :(
For i = 1 To last_col
'"book" is the variable workbook which will house the extracted data
.book.ws.Cells(counter, i) = data(k)
k = k + 1
Next i
End Function
Below is my main sub:
Sub Cycle_wb()
Dim ws As Worksheet
Dim wb As Workbook
Dim book As Workbook
Dim counter As Long, last_row As Long, last_col As Long
Dim i, j, k As Integer
Dim data() As String
counter = 1
open_close
Query_Tv_values
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then
MsgBox "working on " & wb.Name
PerLineItem2 wb
Threshold_Value_PayFull wb
End If
Next
'It's just the part below which I'm having issues with :(
Set book = Workbooks.Add
Set ws = book.Sheets.Add(book.Sheets(1))
ws.Name = "Report_Final"
For Each wb In Workbooks
If (wb.Name <> ThisWorkbook.Name Or wb.Name <> book.Name) Then
Extract_Report_Final wb, counter, book
counter = counter + 1
Next wb
End Sub
Just use something like this to fill out the values in your new workbook
Cells(counter, i).Value = data(i-1)
Check the size of you array vs the length of your loops though - I think the "i"-loop should go
For i = 1 To last_col -1
I want to copy values from one excel file to another excel file, but on later stages of my project, I may need to cross check the value and then paste it in the new excel file. So I dont want to copy whole sheet at a time. I want to copy a value by value.
I was able to open and switch between to excel file but I m not able to copy and paste the values.
Following is the code I tried-
Private Sub CommandButton1_Click()
Dim x As Long
Dim NumRows As Long
Set fromwb = Workbooks.Open("G:\Excel\From.xlsx")
Set towb = Workbooks.Open("G:\Excel\To.xlsx")
fromwb.Activate
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
ReDim a(1 To NumRows)
For x = 1 To NumRows
fromwb.Activate
a(x) = Cells(x, 1).Value
towb.Activate
Cells(x, 1).Value = a(x)
Next x
End Sub
Thanking you in anticipation.
Try out the code below. I hope the comments are very clear!
Option Explicit
Private Sub CommandButton1_Click()
Dim SourceBook As Workbook, DestBook As Workbook
Dim SourceSheet As Worksheet, DestSheet As Worksheet
Dim Index As Long, NumRows As Long
Dim ValidCheck As Boolean
'set references up-front
Set SourceBook = Workbooks.Open("G:\Excel\From.xlsx")
Set SourceSheet = SourceBook.ActiveSheet
With SourceSheet
NumRows = .Range("A", .Rows.Count).End(xlUp).Row '<~ last row in col A
End With
Set DestBook = Workbooks.Open("G:\Excel\To.xlsx")
Set DestSheet = DestBook.ActiveSheet
'loop through col A and write out values to destination
For Index = 1 To NumRows
'...
'do your value validation
'in this space using ValidCheck
'...
If ValidCheck Then '<~ if true write to Dest
DestSheet.Cells(Index, 1) = SourceSheet.Cells(Index, 1)
End If '<~ if not, do not write to Dest
Next Index
End Sub
You just need to specify the to cells as equal to the from cells, no need to loop anything.
Workbooks("To.xlsx").Sheets("ToSheetNameHere").Range("rangehere").Value = Workbooks("From.xlsx").Sheets("FromSheetNameHere").Range("rangehere").Value
Keep in mind if you have macro code in the workbook(s) they will be .xlsm and not .xlsx