Private Sub Workbook_Open()
Dim workbThis As Workbook
Dim workbtarget As Workbook
'Dim RNG As Range
Dim PBR As Variant
' ASSIGN ROW FOR PAGEBREAK
PBR = Array(0, 38, 49, 38, 46, 38, 30, 52, 37, 42, 42, 42, 42, 33)
' Calculate workbook manually
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
.CalculateBeforeSave = True
End With
Sheets(1).Select
Calculate
Set workbThis = ActiveWorkbook
'Add workbook for copy data
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Temp\Report " & Format(Now(), "mm_dd_yyyy_hh") & ".xlsx"
'open a workbook that has same name as the sheet name
Set workbtarget = ActiveWorkbook
workbThis.Activate
Dim I As Integer
'For I = 1 To workbThis.Sheets.Count
' Copy workbook data to another sheet
Copy_sheet_data SH:=workbThis.Sheets("Report").Name, wbtarget:=workbtarget, wbThis:=workbThis
'Next I
'Next I
'close the workbook
workbtarget.Save
workbtarget.Close
workbThis.Save
Set workbtarget = Nothing
Set workbThis = Nothing
'Save current workbook
ThisWorkbook.Save
'Close workbook
Application.Quit
End Sub
Related
I have two files. 1 file contains data with tabs named as company. The second file is to analyse the companies and I have there also tabs which are named in the same name as in tabs in file with copmanies data. In the file where I analyse data I have tab macro where I put information requires for macro. Companies name, file names. When the new copamny comes or the old one will disappear I want to do the same in macro as macro takes information from the tab macro from cells. Now what I want to have is that macro will copy for company A from file with companies data and paste into file with companies analyse. I have used to that loop FOR TO as then macro will copy and paste company A and then B,then C and so on and so forth. The macro is below. First part works. Opens file with data and active however then it doesnt work. I think I mixed variables but I have no idea how to fix it. Any ideas?
Sub CopyData()
Workbooks.Open Range("A10").Value
Dim wb As Workbook
Dim wbk As Workbook
Dim i As Integer
Dim FieldAVal As Worksheet
Dim FieldBVal As Worksheet
Dim Iter As Integer
For Each wb In Application.Workbooks
If wb.Name Like "*Reconciliation*" Then
wb.Activate
Exit For
End If
Next wb
Set wbk = Workbooks(Range("A9").Value)
Sheets("Macro").Select
Range("B6").Select
'define ranges with column numbers
Iter = Cells(1, 3).Value
For i = 1 To Iter
FieldAVal.Name = Cells(i + 14, 2).Value
FieldBVal.Name = Cells(i + 14, 3).Value
Workbooks(wbk).Worksheets(FieldBVal).Range("A1:V1000").Copy _
Destination:=ThisWorkbook.Worksheets(FieldAVal).Range("B2")
Next i
End Sub
I am not sure understanding
Public Sub CopyData()
On Error GoTo ErrHANDLER
Dim wb As Workbook
Dim wbk As Workbook
Dim i As Integer
Dim FieldAVal As Worksheet
Dim FieldBVal As Worksheet
Dim Iter As Integer
'add Variables
Dim secondFileName As String
Dim wbSecondFile As Workbook
Dim openedworkbookNameB As String
Dim openedworkbook As Worksheet
Dim pasteWorksheet As Worksheet
secondFileName = Range("A10").Value
'already opened workbook
openedworkbookNameB = Range("A9").Value
Set wbSecondFile = Workbooks.Open(secondFileName)
'Fail to open
If wbSecondFile Is Nothing Then
Exit Sub
End If
Set openedworkbook = Workbooks(openedworkbookNameB)
'no workbook
If openedworkbook Is Nothing Then
Exit Sub
End If
Call ThisWorkbook.Activate
ThisWorkbook.Sheets("Macro").Select
'ActiveSheet == "Macro" sheet
ActiveSheet.Range("B6").Select
Iter = VBA.Val(ActiveSheet.Cells(1, 3).Value)
For i = 1 To Iter
FieldAVal.name = ActiveSheet.Cells(i + 14, 2).Value
FieldBVal.name = ActiveSheet.Cells(i + 14, 3).Value
Set pasteWorksheet = ThisWorkbook.Worksheets(FieldAVal)
If Not pasteWorksheet Is Nothing Then
openedworkbook.Worksheets(FieldBVal).Range("A1:V1000").Copy _
Destination:=pasteWorksheet.Range("B2")
End If
Set pasteWorksheet = Nothing
Next i
Exit Sub
ErrHANDLER:
'When Raise error
Debug.Print Err.Number & " : " & Err.Description
'debug point Here
'press "F8" Key to Run a Macro Line by Line
Stop
Resume
End Sub
I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.
I have VBA code that contains the range Excel to PPT. So my question is how can I set a dynamic range instead of giving the array values here.
the example below code want same in dynamic:-
MySlideArray = Array(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)
MyRangeArray = Array(Sheet4.Range("A10:AS69"), Sheet9.Range("Q10:AH69"), Sheet10.Range("A1:AX65"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))
I have a Report card that contains all the sheets with Excel range, so when I refer the array it should be capture the Report card Range
Ex
How to build a dynamic range?
ub copiSylwadau()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
Dim MyArray As Variant
Dim iCounter As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
'MyArray = Worksheets("control").Range("rng")
'MsgBox "MyArray"
MySlideArray = Array(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet4.Range("A1:A12"), Sheet9.Range("A1:A12"), Sheet10.Range("A1:A12"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'If iCounter = iCounter < 2 Then
'If rCell And Not rCell.Offset(0, 2) Then
'copy slide template
'myPresentation.Slides(4).Copy
'Set obSlide = myPresentation.Slides.Paste(Index:=iCounter)
' iCounter = iCounter
' End If
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=True)
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
Set MySlideArray = myPresentation.Add(myPresentation.Count + 1)
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = 20
shp.Top = 70
shp.Width = 670
'shp.Height = ppAutoSizeShapeToFitText
End With
Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Cyflwyniad PowerPoint wedi eu greu!"
End Sub
Suggest you create named ranges directly then refer to those in your code.
Example: use the name "Sheet4Range" to name Sheet4.Range("A10:AS69")
In your code:
Sheet4.Range("Sheet4Range")
You can make the definition of the actual Sheet4Range range a Dynamic Named Range (DNR). There are many resources to learn how to construct a DNR. Here's one: https://www.excel-easy.com/examples/dynamic-named-range.html
Beginner in VBA.
What I'm attempting to do:
Copy the first 5 rows _ row 'x' in current worksheet, and paste in a new workbook
New workbooks should be saved in the same directory
This should repeat for every row below the first 5, i.e. rows 1-5 + 6, rows 1-5 + 7, rows 1-5 + 8, etc.
When pasting the rows into the new workbook, I don't want to copy formulas, just format and values
This is what I have so far:
Sub CommandButton1_Click()
Dim MyBook As Workbook, newBook As Workbook
Dim FileNm As String
Set MyBook = ThisWorkbook
FileNm = ThisWorkbook.Path & "\" & "TEST-BOOK.xlsx"
Set newBook = Workbooks.Add
With newBook
MyBook.Sheets("Sheet1").Rows("1:5").Copy .Sheets("Sheet1").Rows("1")
'Save new wb
.SaveAs Filename:=FileNm, CreateBackup:=False
.Close Savechanges:=False
End With
End Sub
It copies the rows 1-5, but I don't know how to add the dynamic extra row-- it also copies all the formulas and embeds them. Assuming the Filename would also have to be in some sort of loop?
Thank you.
hope this helps,
Sub CommandButton1_Click()
Dim wb As Workbook, FileNm As String, LastRow As Long, Headers As Range, wbTemp As Workbook, i As Long
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set wb = ThisWorkbook
'lets suppose your data is in the first worksheet of your book
With wb
LastRow = .Sheets(1).Cells(.Sheets(1).Rows.Count, 1).End(xlUp).Row - 5 'this is to count how many rows you've got
Set Headers = .Sheets(1).Rows("1:5") 'set the headers to copy them every iteration
End With
'copy each row + headers in a new workbook
For i = 1 To LastRow
FileNm = wb.Path & "\" & "TEST-BOOK" & i & ".xlsx" 'add the i to number every workbook from 1 to extra rows you have
Set wbTemp = Workbooks.Add 'add a new workbook
Headers.Copy
wbTemp.Sheets(1).Rows(1).PasteSpecial xlPasteValues 'paste the headers
wb.Sheets(1).Rows(5 + i).Copy
wbTemp.Sheets(1).Rows(6).PasteSpecial xlPasteValues 'copy the next row in the iteration
wbTemp.SaveAs FileNm
wbTemp.Close
Set wbTemp = Nothing
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have 3 workbooks
source workbook
target workbook
reference workbook - (Containing the macro which visible across all workbooks)
Is it possible to change switch between Active workbook ( target workbook) and ( source workbook which was active workbook).
Activate doesn't seem to help me, I do not if this is a bug or what it is. I have stopped in this step for quite sometime now.
This workbook function takes me back to reference workbook.
Hope my question is clear. Appreciate your help.
' My code is in a test macroworkbook
' I am having a workbook opened 1.xlsx
' Opening a workbook countrypricelist.xls
'running the code from
Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim x As Range
Dim y As Range
Set sourcewb = ActiveWorkbook
Set x = sourcewb.Worksheets(1).Range("A:F")
Dim sourceSheet As Worksheet
Set sourceSheet = sourcewb.Worksheets(1)
MsgBox sourceSheet.Name
x.Select
MsgBox sourceSheet.Name
x.Select
MsgBox sourcewb.Name ' This gives me sourceworkbook name.
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Application.Workbooks.Open(Filename)
Set y = targetWorkbook.Worksheets(1).Range("A:F")
y.Select
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
MsgBox targetSheet.Name
Set targetWorkbook = ActiveWorkbook
MsgBox targetWorkbook.Name 'This gives me target workbook name
y.Select
sourcewb.Activate
MsgBox sourcewb.Name ' Source workbook becomes same as targeworkbook.
x.Select
MsgBox sourcewb.Name & " This is the source workbook "
MsgBox targetWorkbook.Name & " This is the target workbook "
With sourcewb.Worksheets(1)
For rw = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(rw, 3) = Application.VLookup(Cells(rw, 2).Value2, x, 3, False)
Cells(rw, 4) = Application.VLookup(Cells(rw, 2).Value2, x, 4, False)
Cells(rw, 5) = Application.VLookup(Cells(rw, 2).Value2, x, 5, False)
Next rw
End With
MsgBox "All required columns from source mapped to target file "
MsgBox "Trying to map from target to source "
Set sourcewb = ActiveWorkbook
MsgBox ActiveWorkbook.Name
Application.ScreenUpdating = False
So If I change the line sourcewb = Thisworkbook my reference is changed to source code to workbook which is not my desired workbook as it contains many other macros for other activities. Hope this is code is fine.
The Excel Workbook Object allows you to programatically open, edit and close any workbook, not just the currently 'Activated' one.
Example:
Dim wb as Excel.Workbook, otherwb as Excel.Workbook
Dim ws as Excel.Worksheet, otherws as Excel.Worksheet
Set wb = Workbooks.Open "somefile.xlsx"
Set otherwb = Workbooks.Open "otherfile.xlsx"
Set ws = wb.Sheets(1)
Set otherws = otherwb.Sheets(1)
' do stuff
ws.Cells(1,1) = otherws.Cells(1,1)
'save changes
wb.Save