I got a problem with copying the range of cells. Usually I used to make it with activecell method. But in current situation it doesn't work. I mean the code does not select the whole range of cells. How can I apply CTRL+A excel shortcut to VBA?
Sub MergeDifferentWorkbooksTogether()
Dim wbk As Workbook
Dim wbk1 As Workbook
Dim Filename As String
Dim Path As String
Dim D As Date
D = Date - 3
Workbooks.Add
ActiveWorkbook.SaveAs "C:\Users\xezer.suleymanov\Desktop\Summary & D"
Set wbk1 = Workbooks("Summary & D")
Path = "\\FILESRV\File Server\Hesabatliq\Umumi\Others\Branchs' TB\Branchs' TB as of 2018\" & D
Filename = Dir(Path & "\*.xlsx")
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Path & "\" & Filename)
wbk.Activate
Range("A6").Value = "Branch Name"
Range("B1").Copy
Range("B6").End(xlDown).Offset(0, -1).Activate
Range(ActiveCell, ActiveCell.End(xlUp).Offset(1, 0)).Select
Selection.PasteSpecial xlPasteAll
Application.CutCopyMode = False
Range("A6").Activate
Range(ActiveCell, ActiveCell.End(xlToRight).End(xlDown)).Copy
wbk1.Activate
Application.DisplayAlerts = False
wbk1.Sheets("Sheet1").Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial xlPasteAll
wbk.Close True
Filename = Dir
Loop
End Sub
You may try something like this...
Dim lr As Long, lc As Long
Dim rng As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(6, Columns.Count).End(xlToLeft).Column
Set rng = Range("A6", Cells(lr, lc))
rng.Copy
Also, if row5 is blank, you may also try...
Range("A6").CurrentRegion.Copy
Related
Been trying to figure out how to copy a cell from worksheet A and paste it down a column in Worksheet B until it matches the same amount of rows as an adjacent column. Take the following screenshot for example. How would I properly accomplish this in VBA? Been trying to figure this out for a while now. All I've been able to do is copy the cell and paste it adjacent to the last cell in the adjacent column instead of down the entire column. The worksheet I'm copying data from is pictured below.
Copy From SpreadSheet down below
Paste to SpreadSheet down below
Current Code
Sub pullSecEquipment()
Dim path As String
Dim ThisWB As String
Dim wbDest As Workbook
Dim shtDest As Worksheet
Dim shtPull As Worksheet
Dim Filename As String
Dim Wkb As Workbook
Dim CopyRng As Range, DestRng As Range
Dim lRow As Integer
Dim destLRow As Integer
Dim Lastrow As Long
Dim FirstRow As Long
Dim UpdateDate As String
ThisWB = ActiveWorkbook.Name
Dim selectedFolder
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
selectedFolder = .SelectedItems(1) & "\"
End With
path = selectedFolder
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = Workbooks("GPnewchapterTEST2.xlsm").Worksheets("START")
'clear content of destination table
shtDest.Rows("8:" & Rows.Count).ClearContents
Filename = Dir(path & "\*.xls*", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
'MsgBox Filename
'''''
'SEC
'''''
If InStr(Filename, "Equipment") <> 0 Then
Dim range1 As Range
Set range1 = Range("E:K")
'For Each Wkb In Application.Workbooks
'For Each shtDest In Wkb.Worksheets
'Set shtPull = Wkb.Sheets(1)
'If shtPull.Name Like "*-*" Then
'last row
destLRow = Wkb.Sheets(1).Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
'1st row
lRow = Wkb.Sheets(1).Cells.Find(what:="EQUIPMENT DESCRIPTION", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'STHours
Dim i As Integer
For i = lRow To destLRow
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 5).Address, Cells(i, 11).Address)
Set DestRng = shtDest.Range("O" & shtDest.Cells(Rows.Count, "O").End(xlUp).Row + 1)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 1).Address, Cells(i, 1).Address)
Set DestRng = shtDest.Range("C" & shtDest.Cells(Rows.Count, "O").End(xlDown).Row)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 3).Address, Cells(i, 3).Address)
Set DestRng = shtDest.Range("S" & shtDest.Cells(Rows.Count, "O").End(xlUp).Row)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
i = i + 2
Next i
'Dim cell As Integer
'Dim empname As String
'destLRow = 8 '' find out how to find first available row
'For cell = 2 To lRow
'empname = Wkb.Sheets(1).Cells(cell, 3).Value & " " & Wkb.Sheets(1).Cells(cell, 4).Value
' shtDest.Cells(8, 5).Value = empname
'shtDest.Cells(8, 1).Value = "Service Electric"
'Next cell
' Wkb.Close Save = False
End If
'End If
Filename = Dir()
Loop
MsgBox "Done!"
End Sub
if you want to do in VBA and want to copy one value in "ALL" column
Cells(1,1).Copy Columns(1)
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
i have 50 workbooks and i made a code to copy from a main one the rows in which are the corespondent names to the other 49 files. the problem is in pasting to the 49 target files - paste method doesn't work. The errors is when the filter doesn't find entries for a name. How can i include a line that if the filter doesn't find a name in the main file, it will paste "no entries this month" in the file with the name that wasn't find? Thank you.
Any help is welcomed.
Sub name1()
Dim ws As Worksheet
Dim rng As Range, rngA As Range, rngB As Range
Dim LRow As Long
Set ws = Sheets("name list")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:M" & LRow)
.AutoFilterMode = False
With rng
.AutoFilter Field:=12, Criteria1:="name1"
Set rngA = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
With rng
.AutoFilter Field:=13, Criteria1:="name1"
Set rngB = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
rng.Offset(1, 0).EntireRow.Hidden = True
Union(rngA, rngB).EntireRow.Hidden = False
End With
End Sub
Sub name11()
Dim lst As Long
Dim rng As Range
Dim i As Integer
Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("A:M"))
rng.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Application.DisplayAlerts = False
Workbooks.Open Filename:= _
"\\HOFS\persons\name1.xlsm" _
, UpdateLinks:=true
With Sheets("tribute").Range("A" & Rows.Count).End(xlUp).Offset(1)
'.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
End With
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = False
Windows("name list.xlsm").Activate
rng.Offset(1, 0).EntireRow.Hidden = False
End Sub
Sub TRANSFER_name1()
Call name1
Call name11
End Sub
Set the last row separately.
' Gives the first empty row in column 1 (A)
lastRow = Worksheets("tribute").Cells(Worksheets("tribute").Rows.Count, 1).End(xlUp).Row + 1
' Pastes values
Worksheets("tribute").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
Its probably much better to avoid copy/paste situations. This can get super time consuming over time.
try somethign like this instead:
With Sheets("tribute").Range("A" & Rows.Count).End(xlUp).Offset(1).value = rng.Value
This is a bit crude but I am sure you can significantly simplify your code if you do.
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer
path = "pathtofolder" & "\"
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet1")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
Set rRng = sheet.Range("b1:b308")
For Each rCell In rRng.Cells
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell
Next rCell
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
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
I'm new to VBA and trying to automate updates to a workbook.
I have a source Workbook A and a destination Workbook B. Both have a sheet called roll out summary. I want the user to update this sheet in A and click update button which should run my macro. This macro should automatically update the sheet in workbook B without opening Workbook B.
I'm trying this code but it doesn't work and gives me an error:
Dim wkb1 As Workbook
Dim sht1 As Range
Dim wkb2 As Workbook
Dim sht2 As Range
Set wkb1 = ActiveWorkbook
Set wkb2 = Workbooks.Open("B.xlsx")
Set sht1 = wkb1.Worksheets("Roll Out Summary") <Getting error here>
Set sht2 = wkb2.Sheets("Roll Out Summary")
sht1.Cells.Select
Selection.Copy
Windows("B.xlsx").Activate
sht2.Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
sht1 and sht2 should be declare as Worksheet. As for updating the workbook without opening it, it can be done but a different approach will be needed. To make it look like you're not opening the workbook, you can turn ScreenUpdating on/off.
Try this:
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Application.ScreenUpdating = False
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open("B.xlsx")
Set sht1 = wkb1.Sheets("Roll Out Summary")
Set sht2 = wkb2.Sheets("Roll Out Summary")
sht1.Cells.Copy
sht2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkb2.Close True
Application.ScreenUpdating = True
Use this - This worked for me
Sub GetData()
Dim lRow As Long
Dim lCol As Long
lRow = ThisWorkbook.Sheets("Master").Cells()(Rows.Count, 1).End(xlUp).Row
lCol = ThisWorkbook.Sheets("Master").Cells()(1, Columns.Count).End(xlToLeft).Column
If Sheets("Master").Cells(2, 1) <> "" Then
ThisWorkbook.Sheets("Master").Range("A2:X" & lRow).Clear
'Range(Cells(2, 1), Cells(lRow, lCol)).Select
'Selection.Clear
MsgBox "Creating Updated Master Data", vbSystemModal, "Information"
End If
'MsgBox ("No data Found")
'End Sub
cell_value = Sheets("Monthly Summary").Cells(1, 4)
If cell_value = "" Then
Filename = InputBox("No Such File Found,Enter File Path Manually", "Bad Request")
Else
MsgBox (cell_value)
Path = "D:\" & cell_value & "\"
Filename = Dir(Path & "*.xlsx")
If Filename = "" Then
Filename = InputBox("No Such File Found,Enter File Path Manually", "Bad Request")
Else
Do While Filename <> ""
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
ActiveWorkbook.Sheets("CCA Download").Activate
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Range("A2:X" & LastRow).Select
Selection.Copy
ThisWorkbook.Sheets("Master").Activate
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Select
'Required after first paste to shift active cell down one
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(0, -3).Select
Selection.PasteSpecial xlPasteValues
Workbooks(Filename).Close
Filename = Dir()
Loop
End If
End If
Sheets("Monthly Summary").Activate
'Sheets("Monthly Summary").RefreshAll
Dim pvtTbl As PivotTable
For Each pvtTbl In ActiveSheet.PivotTables
pvtTbl.RefreshTable
Next
'Sheets("Monthly Sumaary").Refresh
MsgBox "Monthly MIS Created Sucessfully", vbOKCancel + vbDefaultButton1, "Sucessful"
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub