I am trying to copy a range of cells on a sheet in one workbook to the bottom of a sheet in another workbook. I keep getting "Application-defined or object-defined error" on the copy line.
Dim NewFileName As String
Dim BAHFileName As String
NewFileName = "Filename"
BAHFileName = "Other Filename"
LastRow = Sheets("All").UsedRange.Rows.Count
Workbooks(NewFileName).Sheets("All").Range(Cells(2, 1), Cells(LastRow, 15)).Copy
Windows(BAHFileName & ".xlsx").Activate
LastRow = Workbooks(BAHFileName).Sheets(1).UsedRange.Rows.Count + 1
Workbooks(BAHFileName).Sheets(1).Cells(LastRow, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Talking to yourself?
Practise with this code to avoid using selects.
I am not sure of the situation of your workbooks, so you will have to adjust workbook names and sheet names accordingly.
Sub Button1_Click()
Dim WB As Workbook
Dim bk As Workbook
Dim LastRow As Long
Dim Lrow As Long
Dim rng As Range
Dim ws As Worksheet
Dim sh As Worksheet
Set WB = ThisWorkbook
Set bk = Workbooks("MyWorkbook.xlsx")
Set ws = WB.Sheets("All")
Set sh = bk.Sheets(1)
With ws
LastRow = .UsedRange.Rows.Count
Set rng = .Range(.Cells(2, 1), .Cells(LastRow, 15))
End With
With sh
Lrow = .UsedRange.Rows.Count + 1
rng.Copy .Cells(Lrow, 1)
End With
End Sub
I needed to select the sheet before copying.
Dim NewFileName As String
Dim BAHFileName As String
NewFileName = "Filename"
BAHFileName = "Other Filename"
LastRow = Sheets("All").UsedRange.Rows.Count
Sheets("All").Select
Workbooks(NewFileName).Sheets("All").Range(Cells(2, 1), Cells(LastRow, 15)).Copy
Windows(BAHFileName & ".xlsx").Activate
LastRow = Workbooks(BAHFileName).Sheets(1).UsedRange.Rows.Count + 1
Workbooks(BAHFileName).Sheets(1).Cells(LastRow, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Related
first timer here, so go easy on me :)
Only been using VBA for a few months on work projects and I have hit a wall with what I can google, figured Id post the problem here.
I have a button that will open a source workbook and copy a specific range of cells from the source workbook to the destination workbook. This range of cells to be copied is determined by a for loop that starts at row 2 and loops to the last row of data. I have this code working in another project, but it appears to not want to run when its targeted at a different workbook.
Appreciate the help and any advice on the code in general would be welcome :)
Private Sub CommandButton1_Click()
Dim lastRow, i, erow As Integer
Dim filename As String
Dim fname As Variant
Dim dwbk, swbk As Workbook
Dim sws, dws As Worksheet
Dim r1 As Range
Set dwbk = ThisWorkbook
Set dws = dwbk.Sheets("Call OFF")
'On Error GoTo ErrHandling
'Application.ScreenUpdating = False
FileArray = Application.GetOpenFilename(Title:="Select file(s)", MultiSelect:=True)
For Each fname In FileArray
Set swbk = Workbooks.Open(fname)
Set sws = swbk.Sheets("Allocations")
lastRow = sws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
Range(Cells(i, "A"), Cells(i, "B")).Select
Selection.Copy
dwbk.Sheets("CALL OFF").Activate
erow = Worksheets("CALL OFF").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Worksheets("CALL OFF").Cells(erow, 2).PasteSpecial xlPasteValues
swbk.Activate
Next i
Next
'Application.ScreenUpdating = True
' End If
'Done:
' Exit Sub
'
'ErrHandling:
' MsgBox "No file selected"
End Sub
Thanks.
You are not specifing the parent on the copy range.
Range(Cells(i, "A"), Cells(i, "B")).Select
Change to:
sws.Range(sws.Cells(i, "A"), sws.Cells(i, "B")).Copy
and remove the Selection.Copy line
But you can speed thing up a little and remove the loop by assigning the values directly:
Private Sub CommandButton1_Click()
Dim lastRow As Long, erow As Long
Dim filename As String
Dim fname As Variant
Dim dwbk As Workbook, swbk As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim r1 As Range
Set dwbk = ThisWorkbook
Set dws = dwbk.Sheets("Call OFF")
'On Error GoTo ErrHandling
'Application.ScreenUpdating = False
FileArray = Application.GetOpenFilename(Title:="Select file(s)", MultiSelect:=True)
For Each fname In FileArray
Set swbk = Workbooks.Open(fname)
Set sws = swbk.Sheets("Allocations")
lastRow = sws.Range("A" & Rows.Count).End(xlUp).Row
erow = dws.Cells(dws.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
dws.Cells(erow, 2).Resize(lastRow - 1, 2).Value = sws.Range(sws.Cells(2, 1), sws.Cells(lastRow, 2)).Value
Next fname
'Application.ScreenUpdating = True
' End If
'Done:
' Exit Sub
'
'ErrHandling:
' MsgBox "No file selected"
End Sub
I am trying to copy data from workbook1 and pasting to workbook2 as per there valves if the valve is not same as previous than create a new sheet in the workbook and start pasting valve in the new sheet and do until did not find blank row in workbook1.
Sub icopy()
Dim LastRow As Long, Limit2 As Long, c As Long, d As Long, erow As Long
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, wb As Workbook,
wb1 As Workbook
If Is_WorkBook_Open("test.xlsx") Then
Set wb = Workbooks("test.xlsx")
Else
Set wb = Workbooks.Open("D:\Data\test.xlsx")
End If
Set sh1 = wb.Sheets("Sheet1")
LastRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
'wb.Close
MsgBox LastRow
For i = 2 To LastRow
If sh1.Cells(i, 1) = sh1.Cells(i + 1, 1) Then
If (i = 2) Then
Set wb1 = Workbooks.Open("D:\Data\Data1.xlsx")
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh1.Cells(2, 1)
Set sh2 = wb1.ActiveSheet.Name
End If
sh1.Range(Cells(i, 1), Cells(i, 3)).Copy
erow = sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'sh2.Cells(erow, 1).Select
sh2.Cells(erow, 3).Paste
sh2.Paste
ActiveWorkbook.Save
Else
MsgBox i
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh1.Cells(i + 1, 1)
End If
Next i
'erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'ActiveSheet.Cells(erow, 1).Select
' ActiveSheet.Paste
'ActiveWorkbook.Save
'ActiveWorkbook.Close
'Application.CutCopyMode = False
End Sub
Function Is_WorkBook_Open(ByVal strWorkbookName As String) As Boolean
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(strWorkbookName)
If Err Then
Is_WorkBook_Open = False
Else
Is_WorkBook_Open = True
End If
End Function
since I understand your valve data are adjacent (i.e. all same valve data are within one block of adjacent rows), you could consider the following:
Option Explicit
Sub icopy()
Dim sh1 As Worksheet, sh2 As Worksheet, wb1 As Workbook
Dim iRow As Long
If Is_WorkBook_Open("test.xlsx") Then
Set sh1 = Workbooks("test.xlsx").Sheets("Sheet1")
Else
Set sh1 = Workbooks.Open("D:\Data\test.xlsx").Sheets("Sheet1")
End If
Set wb1 = Workbooks.Open("D:\Data\Data1.xlsx") ' open your target workbook
With sh1
iRow = 2
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
Do While iRow <= .Rows.Count
.AutoFilter field:=1, Criteria1:=.Cells(iRow, 1).Value
wb1.Sheets.Add(After:=wb1.Sheets(wb1.Sheets.Count)).name = .Cells(iRow, 1).Text
With .Resize(, 3).SpecialCells(xlCellTypeVisible)
.copy Destination:=wb1.Sheets(.Cells(iRow, 1).Text).Range("a1")
iRow = .Areas(.Areas.Count).Rows(.Areas(.Areas.Count).Rows.Count).row + 1
End With
Loop
End With
.AutoFilterMode = False
End With
End Sub
I got stuck in the below-mentioned code, what I want to do is to get the value from Range("C4:C" & LastRow) in worksheets X2 that will b changing every time and compare each value with all open workbooks name. If match found then search that value in A column of worksheet X1 and copy all those rows.
The final objective is to paste those rows into those open workbooks which have the same value. For eg: Range C4 has TW00 then the code will search workbooks which have name "TW00.xlsx" and copy all the rows from worksheet X1 which have TW00 value in column A in the worksheet named TW00.xlsx.
Dim BookNames()
ReDim BookNames(Windows.Count)
n = 1
For n = 1 To Windows.Count
BookNames(n) = Workbooks(n).Name
If Workbooks(n).Name = Workbooks("A.xlsx").Worksheets("X2").Range("C4:C" & LastRow).Value Then
Set Rng = Workbooks("A.xlsx").Worksheets("X1").Range("A2:A50000")
For Each c In Rng.Cells
If c.Value = Workbooks("A.xlsx").Worksheets("X2").Range("C4").Value Then
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng,
Workbooks("A.xlsx").Worksheets("X1").Rows(c))
Else
Set CopyRng = Workbooks("A.xlsx").Worksheets("X1").Rows(c)
End If
End If
Next c
CopyRng.Copy
Workbooks(n).Activate
Worksheets.Add
ActiveSheet.Name = "X1"
ActiveSheet.Paste
End If
Next n
is that code help you?
Sub test()
Dim lastRow As Long
dim sheetName as string
Dim sourceDataSheet As worksheet
Dim sourceSheetsName as worksheet
dim targetDataSheet as worksheet
Dim wkb As Variant
set sourceDataSheet = ActiveWorkbook.Worksheets("X2")
set sourceSheetsName = ActiveWorkbook.Worksheets("X1")
With sourceSheetsName
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
sheetName = .Cells(lastRow, "A")
For Each wkb In Application.Workbooks
If wkb.Name <> .Name And wkb.Name = sheetName Then
set targetDataSheet = wkb.Worksheets.Add
with sourceDataSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
for i = 1 to lastRow
if .Cells(i, "A").Value = sheetName then
.Cells(i, "A").EntireRow.Copy
targetDataSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
end if
next i
end with
End If
Next wkb
End With
End Sub
I have 7 productivity files which I need to copy the data from the sheet titled worktracker and paste these in the worktracker sheet in the masterfile, but I'm getting:
Run-time error 1004
Method Range of object_Worksheet failed.
Private Sub CommandButton1_Click()
Dim file As String
Dim myPath As String
Dim wb As Workbook
Dim rng As Range
Dim lastrow As Long, lastcolumn As Long
Dim wbMaster As Workbook
Set wbMaster = Workbooks("WorkTracker_Master.xlsm")
Set rng = wbMaster.Sheets("WorkTracker").Range("A4:W4")
myPath = "\\BMGSMP1012\GBDMC_Team$\GBDM_ContentManagement\+CM_Reports\Productivity Reports\FY18\"
file = Dir(myPath & "*.xls*")
While (file <> "")
Set wb = Workbooks.Open(myPath & file)
lastrow = wb.Worksheets("WorkTracker").Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = wb.Worksheets("WorkTracker").Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cell(2, 1)(lastrow, lastcolumn)).Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close
erow = WorkTracker.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination = Worksheets("WorkTracker").Range(Cells(erow, 1), Cells(erow, 4))
wb.Close SaveChanges:=True
Set wb = Nothing
file = Dir
Wend
Application.CutCopyMode = False
End Sub
You need to fully qualify all your objects, a comfortable and easy way, is to seperate each Workbook by using a nested With statement.
Also, as #YowE3K already mentioned in the comments above, you have a syntax error when defining the copied Range.
Try the code below, inside your While (file <> "") loop, after you Set wb = Workbooks.Open(myPath & file) :
With wb.Worksheets("WorkTracker")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy
End With
With wbMaster.Worksheets("WorkTracker")
' get first empty row in column "A"
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' paste in the first empty row
.Range("A" & erow).PasteSpecial
End With
wb.Close SaveChanges:=True
Set wb = Nothing
Code works fine as it imports data from sheets of different workbooks with name Trippings_15.
But i want the program to import sheets with name Trippings_Jan_15, Trippings_Feb_15, Trippings_March_15, etc from workbook 1,2,3 respectively when i use Trippings_15 in code or I can simply give the absolute address of that sheet irrespective of tab name like sheet7 from all workbooks.
I am making a database where all monthly trippings of 2015 will be shown a single sheet.
Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FolderPath As String, Filepath As String, Filename As String
FolderPath = "D:\Copy Multiple Excel to One master\"
Filepath = FolderPath & "*.xls*"
Dim lastRow As Long, lastCol As Long, eRow As Long
Dim wb As Workbook, ws As Worksheet
Application.DisplayAlerts = False
Filename = Dir(Filepath)
Do While Filename <> ""
eRow = Sheet1.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
Set wb = Workbooks.Open(FolderPath & Filename)
On Error Goto NextFile
Set ws = wb.Worksheets("Trippings_15")
With ws
lastRow = .Cells(.Rows.count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.count).End(xlToLeft).Column
.Range(.Cells(5, 1), .Cells(lastRow, lastCol)).Copy
Sheet1.Cells(eRow, 1).PasteSpecial xlPasteValues
End With
NextFile:
On Error Goto 0
wb.Close False
Filename = Dir
Loop
Application.DisplayAlerts = True
End Sub
Try this. The logic here is that you predefine the months which you will insert in the "Trippings_15" string. Also, add a function to test whether sheet exists, instead of using the clunky On Error Resume Next
Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FolderPath As String, Filepath As String, Filename As String
'### DEFINE YOUR BASE STRING TO BE UPDATED WITH EACH MONTH
Dim baseSheetName$
baseSheetName = "Trippings_{}_15"
Dim sheetName as String 'This will be updated later...
'### DEFINE AN ARRAY OF MONTHS
Dim months, m
months = Array("JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC")
FolderPath = "D:\Copy Multiple Excel to One master\"
Filepath = FolderPath & "*.xls*"
Dim lastRow As Long, lastCol As Long, eRow As Long
Dim wb As Workbook, ws As Worksheet
Application.DisplayAlerts = False
Filename = Dir(Filepath)
Do While Filename <> ""
eRow = Sheet1.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
Set wb = Workbooks.Open(FolderPath & Filename)
For Each m in months '## Iterate over each month in your array
sheetName = Replace(baseSheetName,"{}",m) '## this is the month sheet name like "Trippings_Jan_15", etc.
If SheetExists(wb, sheetName) Then '## Check whether this sheet exists before tryingto use it
Set ws = wb.Worksheets(sheetName)
With ws
lastRow = .Cells(.Rows.count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.count).End(xlToLeft).Column
.Range(.Cells(5, 1), .Cells(lastRow, lastCol)).Copy
Sheet1.Cells(eRow, 1).PasteSpecial xlPasteValues
End With
End If
Next m
wb.Close False
Filename = Dir
Loop
Application.DisplayAlerts = True
End Sub
Here is the function SheetExists:
Function SheetExists(wb as Workbook, s as String)
Dim ws as Worksheet
Dim ret as Boolean
For Each ws in wb.Worksheets
If ws.Name = s Then
ret = True
Exit For
End If
Next
SheetExists = ret
End Function