Copy content from closed work book column - vba

As said in the title I'm trying to copy data from a column into a new workbook as its a weekly report where the data I add in this column remains valid.
Sub copyColData00()
Dim lastRow As Long
Dim myApp As Excel.Application
Dim wkBk As Workbook
Dim wkSht As Object
Dim mnt As String
Set myApp = CreateObject("Excel.Application")
mnt = InputBox("Enter Filename")
Set wkBk = Workbooks.Open("\\n\Documents\" & mnt & ".xlsx")
lastRow = wkBk.Sheets(1).Range("R" & Rows.Count).End(xlUp).Row
wkBk.Sheets(1).Range("R1:R" & lastRow).Copy
myApp.DisplayAlerts = False
wkBk.Close
myApp.Quit
Set wkBk = Nothing
Set myApp = Nothing
Set wkBk = ActiveWorkbook
Set wkSht = wkBk.Sheets("Sheet1")
wkSht.Activate
Range("R1").Select
wkSht.Paste
Exit Sub
End Sub
My problem is that I want it to past it directly while there I get a prompt that ask if I want to copy all the data in the clip board or not and my second problem is that at
Set wkSht = wkBk.Sheets("Sheet1")
It gives me the error subscript out of range I've trouble understanding what happens there if someone could help it would be nice!

This is a lot easier way to do that:
Sub copyColData00()
Dim lastRow As Long
Dim wkBk1 As Workbook, wkBk2 As Workbook
Dim wkSht As Object
Dim mnt As String
mnt = InputBox("Enter Filename")
Set wkBk1 = ActiveWorkbook
Set wkBk2 = Workbooks.Open("\\n\Documents\" & mnt & ".xlsx")
lastRow = wkBk2.Sheets(1).Range("R" & Rows.Count).End(xlUp).Row
wkBk1.Sheets(1).Range("R1:R" & lastRow).Value = wkBk2.Sheets(1).Range("R1:R" & lastRow).Value 'change which sheet you want for wkBk1
wkBk2.Close
End Sub

Related

Excel adjust to non-active worksheets while looping through directory

I have the following macro to loop through directory and put data in my master file. The masterfolder contains all information about employee hours spend on a specific project. However, the sheet name of the employee hour files (non-master files) might differ. I managed to change this for the activesheet (master sheet) but I'm not sure how to adjust this for the non-active (non-master) sheets (in formula this specific sentence: Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
Option Explicit
Sub CopyToMasterFile()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
Dim wbname As String
Dim sheetname As String
wbname = ActiveWorkbook.Name
sheetname = ActiveSheet.Name
FolderPath = "C:\test file\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check is master is open already
For Each WkBk In Workbooks
If WkBk.Name = wbname Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks(wbname)
Set MasterSht = MasterWB.Sheets(sheetname)
Else
Set MasterWB = Workbooks.Open(FolderPath & wbname)
Set MasterSht = MasterWB.Sheets(sheetname)
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = wbname And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "AE").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
If CurrentWBSht.Cells(CurrentShtRowRef, "AE").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("AE" & CurrentShtRowRef & _
":AQ" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, _
CurrentWBSht.Range("AE" & CurrentShtRowRef & _
":AQ" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy
MasterSht.Cells(MasterWBShtLstRw + 1, 1).PasteSpecial xlPasteValues
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "master.xlsx" And ....
TempFile = Dir
Loop
ActiveSheet.Range("A1:M200").RemoveDuplicates Columns:=Array(1, 2, 4, 8, 9, 10, 11, 12), Header:=xlYes
End Sub
There are a few ways to refer to a worksheet, without knowing their names in advance:
'To get a specific worksheet:
Set CurrentWBSht = CurrentWB.Worksheets(10)
'To get the last worksheet:
Set CurrentWBSht = CurrentWB.Worksheets(Worksheets.Count)
'To get the pre last worksheet:
Set CurrentWBSht = CurrentWB.Worksheets(Worksheets.Count-1)
If the workbook only has 1 sheet then you can simply do this:
Set CurrentWBSht = CurrentWB.Sheets(1)
If there are more than 1 sheet in the 'non-master' workbook, you could have this:
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Dim oWS As Worksheet
' Loop through all sheets to find the sheet we want
For Each oWS In CurrentWB.Worksheets
If oWS.Name = sheetname Then
Set CurrentWBSht = oWS
Exit For
End If
Next
You could add a flag in the loop above to confirm if you found a sheet
Also, from what I can see, your macro is in your master sheet?. If that's the case, you don't need to do the check if the 'Master workbook' is open. You can just use ThisWorkbook.Worksheets(1).Name (ThisWorkbook is the object for the workbook where your macro is running from)

Error while trying to copy Worksheet

I am having the error "Copy Method of Worksheeet class failed" on this line:
.Sheets("Blank Forecast Sheet").Copy After:=.Sheets("Button Sheet")
I've looked around and couldn't find any solution. This code is ,as can be seen, supposed to add new sheets that I will rename, once, I get this problem solved.
Sub addnewsheet()
Dim wbook As Workbook
Set wbook = Application.ActiveWorkbook
Dim newsheet As Worksheet
Dim datasheet As Worksheet
Dim m As String
Dim y As Integer
m = Format(Date, "mmmm")
y = Format(Date, "yyyy")
With wbook
.Sheets("Blank Forecast Sheet").Copy After:=.Sheets("Button Sheet")
End With
End Sub
Use ThisWorkbook instead of wbook and .Worksheets instead of .Sheets:
Sub addnewsheet()
Dim newsheet As Worksheet
Dim datasheet As Worksheet
Dim m As String
Dim y As Integer
m = Format(Date, "mmmm")
y = Format(Date, "yyyy")
With ThisWorkbook
.Worksheets("Blank Forecast Sheet").Copy After:=.Worksheets("Button Sheet")
End With
End Sub

Excel VBA - loop over files in folder, copy range, paste in this workbook

I have 500 excel files with data. I would merge all this data into one file.
Task list to achieve this:
I want to loop over all the files in a folder
open the file,
copy this range "B3:I102"
paste it into the 1st sheet of the active workbook
repeat but paste new data underneath
I've done task 1-4 but i need help with task 5, last bit - pasting the data under the existing data and making it dynamic. I've highlighted this bit with '#### in my code.
Here is my code which I've put together from other people's question :)
Any suggestions on how to do this?
Sub LoopThroughFiles()
Dim MyObj As Object,
MySource As Object,
file As Variant
Dim wbThis As Workbook 'workbook where the data is to be pasted, aka Master file
Dim wbTarget As Workbook 'workbook from where the data is to be copied from, aka Overnights file
Dim LastRow As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
'set to the current active workbook (the source book, the Master!)
Set wbThis = ActiveWorkbook
Set sht1 = wbThis.Sheets("Sheet1")
Folder = "\\dne\ldc\research-dept\3 CEEMEA\15. EMB\Turkey\TLC Overnight & Weekly Reports\weekly (majeed)\"
Fname = Dir(Folder)
While (Fname <> "")
Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)
wbTarget.Activate
Range("b3:i102").Copy
wbThis.Activate
'################################
'NEED HELP HERE. I GET A ERROR HERE. NEEDS TO BE MORE DYNAMIC.
sht1.Range("b1:i100").PasteSpecial
Fname = Dir
'close the overnight's file
wbTarget.Close
Wend
End Sub
I think using variant is useful than copy method.
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object
file As Variant
Dim wbThis As Workbook 'workbook where the data is to be pasted, aka Master file
Dim wbTarget As Workbook 'workbook from where the data is to be copied from, aka Overnights file
Dim LastRow As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim vDB As Variant
'set to the current active workbook (the source book, the Master!)
Set wbThis = ActiveWorkbook
Set sht1 = wbThis.Sheets("Sheet1")
Folder = "\\dne\ldc\research-dept\3 CEEMEA\15. EMB\Turkey\TLC Overnight & Weekly Reports\weekly (majeed)\"
Fname = Dir(Folder)
While (Fname <> "")
Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)
vDB = wbTarget.Sheets(1).Range("b3:i102")
'################################
'NEED HELP HERE. I GET A ERROR HERE. NEEDS TO BE MORE DYNAMIC.
sht1.Range("b" & Rows.Count).End(xlUp)(2).Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Fname = Dir
'close the overnight's file
wbTarget.Close
Wend
End Sub
I see you already added a long variable for this, so do a lookup on the last row before you paste. Also, paste in a single cell in case of varying amounts of data.
I altered your script as follows.
Sub LoopThroughFiles()
Dim MyObj As Object,
MySource As Object,
file As Variant
Dim wbThis As Workbook 'workbook where the data is to be pasted, aka Master file
Dim wbTarget As Workbook 'workbook from where the data is to be copied from, aka Overnights file
Dim LastRow As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
'set to the current active workbook (the source book, the Master!)
Set wbThis = ActiveWorkbook
Set sht1 = wbThis.Sheets("Sheet1")
Folder = "\\dne\ldc\research-dept\3 CEEMEA\15. EMB\Turkey\TLC Overnight & Weekly Reports\weekly (majeed)\"
Fname = Dir(Folder)
While (Fname <> "")
Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)
wbTarget.Activate
Range("b3:i102").Copy
wbThis.Activate
'Just add this line:
lastrow = sht1.Range("b1").End(xlDown).Row + 1
'And alter this one as follows:
sht1.Range("B" & lastrow).PasteSpecial
Fname = Dir
'close the overnight's file
wbTarget.Close
Wend
End Sub
How about you define sht1.Range("b1:i102") as variables instead of constants?
Something like:
Dim x As Long
Dim y As Long
x = 1
y = 1
Dim rng As Range
Set rng = Range("b"&x ,"i"&y)
And then use:
sht1.rng
Just remember to add x = x+100 and y = y +100 at the end of your while statement (so it will update new values between each paste.)
Why don't you place a counter? Like this:
Dim counter As Long
counter = 1
And then:
While (Fname <> "")
Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)
wbTarget.Activate
Range("b3:i102").Copy
wbThis.Activate
'Solution:
sht1.Range("b" & counter & ":i" & counter + 99).PasteSpecial
counter = counter + 100
Fname = Dir
'close the overnight's file
wbTarget.Close
Wend
You can addbelow section as step 5. I have used offset with Variable incremented in loop
Dim i as Long
Range("B1").Select // 'select the column where you want to paste value
ActiveCell.Offset(i, 0).Select //'place the offset counter with variable
sht1.Range("b1:i100").PasteSpecial
i=i+100 //'increment the offset with the number of data rows

errors pulling key information from multiple excel workbooks

I am attempting to write a macro in a workbook whose purpose is to display the key information from each of a set of excel files. the first column contains the name of the file which will be used in the code.
the code I have written so far should loop through the list of 11 file names in the summary sheet and pull the info called from cell E21 in each of those files and place it in cell Hx in the summary sheet.
I have had no luck getting it to work so far, my first error im getting is "invalid Qualifier" on the line that says "MySheet". I know that there are alot of other mistakes here as I have never attempted to write a sub that pulls from other closed workbooks.
My code is as follows:
Option Explicit
Sub OEEsummmary()
Dim Gcell As Range
Dim Txt$, MyPath$, MyWB$, MySheet$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
MySheet = ActiveSheet.Name
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Txt
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With ThisWorkbook.ActiveSheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
Ive looked at what an invalid qualifier error is and i dont understand what i have wrong with that part of my code. Any help with this and any other blinding errors would be greatly appreciated!
The issue I see that's causing the Invalid Qualifier error is that you are declaring MySheet as a string, but trying to use it as a Worksheet object. Below I've declared it as a worksheet and set it to the Activesheet. I also changed the ThisWorkbook.ActiveSheet reference to MySheet, which I think is what you want. Also changed Txt to Text:
Sub OEEsummmary()
Dim Gcell As Range
Dim MySheet As Worksheet
Dim Txt$, MyPath$, MyWB$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
Set MySheet = ActiveSheet
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Text
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With MySheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub

VBA Error '9' subscript Out of Range when copying worksheets

I'm Currently trying to create a code that will grab all the worksheets from a number of workbooks and paste them into a pre-selected workbook.
So far the code works, but only some of the time, the rest of the time it tells me that the workbooks("Name").Sheet(i) subscript out of range. There doesn't seem to be a pattern to the Error
If Not UserForm1.filePath = "" Then
Dim db As DAO.Database
Set db = OpenDatabase(UserForm1.filePath)
Dim rst As DAO.Recordset
Set rst = db.OpenRecordset("tIO")
Dim Filename As String
Dim WS As Worksheet
Dim Counter As Integer
Dim i As Integer
i = 1
While Not rst.EOF
If Not Filename = rst!Filename Then
Filename = rst!Filename
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(Filename:=Filename)
Counter = Counter + 1
'Loop through all of the worksheets in the Active workbook
For Each WS In wbSource.Worksheets
WS.Activate
WS.Select
WS.Name = (WS.Name & "_" & Counter)
WS.Activate
WS.Select
WS.Copy After:=Workbooks("Appendix 3 V0_00.xls").Sheets(i)
i = i + 1
Next
wbSource.Close False
End If
rst.MoveNext
Wend
End If
I wrote the Workbooks("Appendix 3 V0_00.xls") as it threw the same error up even more often when i used the with so now it looks like this;
If Not UserForm1.filePath = "" Then
Dim db As DAO.Database
Set db = OpenDatabase(UserForm1.filePath)
Dim rst As DAO.Recordset
Set rst = db.OpenRecordset("tIO")
Dim Filename As String
Dim WS As Worksheet
Dim Counter As Integer
Dim j As Integer
While Not rst.EOF
If Not Filename = rst!Filename Then
Filename = rst!Filename
Dim wbSource As Workbook
If Dir(Filename) <> "" Then
Set wbSource = Workbooks.Open(Filename:=Filename)
Counter = Counter + 1
'Loop through all of the worksheets in the Active workbook
For j = 1 To wbSource.Worksheets.Count
wbSource.Sheets(j).Activate
wbSource.Sheets(j).Select
wbSource.Sheets(j).Name = (wbSource.Sheets(j).Name & "_" & Counter)
wbSource.Sheets(j).Activate
wbSource.Sheets(j).Select
wbSource.Sheets(j).Copy After:=Workbooks("Appendix 3 V0_00.xls").Sheets(Workbooks("Appendix 3 V0_00.xls").Sheets.Count)
Next
wbSource.Close False
End If
End If
rst.MoveNext
Wend
End If
wb.SaveAs (Module1.AppendicesFolder & "\" & UserForm1.TxtJobNumber & " " & UserForm1.TxtJobName & " Appendix3 V0.00.xls")
wb.Close
xlApp.Quit
End Sub
It seems to only happen after i have used it more than once could it be excel not closing down properly?
If the error is on WS.Copy After:=Workbooks("Appendix 3 V0_00.xls").Sheets(i), I suggest that you create a new Workbook variable.
Dim Wb As WorkBook
Set Wb = Workbooks("Appendix 3 V0_00.xls")
And then you use it into your copy line :
WS.Copy After:=Wb.Sheets(Wb.Sheets.Count)
Or as suggested by #Jeeped, you can simply use a With statement :
With Workbooks("Appendix 3 V0_00.xls")
If Not UserForm1.filePath = "" Then
Dim db As DAO.Database
Set db = OpenDatabase(UserForm1.filePath)
Dim rst As DAO.Recordset
Set rst = db.OpenRecordset("tIO")
Dim Filename As String
Dim WS As Worksheet
Dim Counter As Integer
Dim i As Integer
i = 1
While Not rst.EOF
If Not Filename = rst!Filename Then
Filename = rst!Filename
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(Filename:=Filename)
Counter = Counter + 1
'Loop through all of the worksheets in the Active workbook
For Each WS In wbSource.Worksheets
WS.Activate
WS.Select
WS.Name = (WS.Name & "_" & Counter)
WS.Activate
WS.Select
WS.Copy After:= .Sheets(.Sheets.Count)
i = i + 1
Next
wbSource.Close False
End If
rst.MoveNext
Wend
End If
End With
Since there doesn't seem to be a pattern to the error you're getting, my guess is that the error stems from Sheets(i) not from Workbooks("Appendix 3 V0_00.xls") since you're not choosing a specific order of choosing worksheets from wbSource. To be quite honest, I can't really see what may be wrong in your code, but instead of
For Each WS in wbSource.Worksheets
try
For j = 1 To wbSource.Worksheets.Count
replacing every WS with Sheets(j). Technically speaking, this should not make much of a difference, but I have gotten rid of VBA errors many times by just making seemingly useless adjustments to my code. If you figure out the solution, please post it; I'm curious to see how you resolved the problem.