i have a worksheet with an image and 2 buttons. (invoice)
i would like to copy the worksheet with the image but without the 2 buttons into a new sheet of a new workbook and i wanna do it with a vba macro.
in the moment i do it with the usual copy command and use an extra delete command for the 2 buttons.
i am sure there is a easier way to do it.
i tried this...
Application.CopyObjectsWithCells = False
Sheets("invoice").Select
Sheets("invoice").Move After:=Workbooks("invoices").Sheets(1)
Application.CopyObjectsWithCells = True
these looses the buttons but the image is also gone. but i would like to keep the image.
i hope you guys can help me with this.
thanks in advance.
The explanations are in the comments in the code below:
Option Explicit
Sub CopySheet_WO_Btn()
Dim newWB As Workbook
Dim ShtOrig As Worksheet
Dim Obj As OLEObject
Dim PicShape As Shape
Dim PicLeft As Double
Dim PicTop As Double
Set ShtOrig = ThisWorkbook.Sheets("invoice")
' loop through all objects in "invoice" sheet
For Each Obj In ShtOrig.OLEObjects
' if OLE Object is type CommanButton make it Un-Visible (not to copy with the sheet)
If Obj.progID = "Forms.CommandButton.1" Then
Obj.Visible = False
End If
Next Obj
Set newWB = Workbooks.Add(xlWBATWorksheet)
ShtOrig.Copy newWB.Sheets(1)
' loop through all shapes in "invoice" sheet and copy the pictures
For Each PicShape In ShtOrig.Shapes
If PicShape.Name = "Picture 1" Then
PicLeft = PicShape.Left
PicTop = PicShape.Top
PicShape.Copy
newWB.Sheets(1).Paste
Selection.ShapeRange.Left = PicLeft
Selection.ShapeRange.Top = PicTop
End If
Next PicShape
' loop again and return the CommandButtons to be Visible in "invoice" sheet
For Each Obj In ShtOrig.OLEObjects
Obj.Visible = True
Next Obj
End Sub
Related
I am still very new to VBA and am trying to combine certain worksheets from different workbooks.
For example:
I have a workbook called "One" with multiple worksheets (A,B,C,D).
I have another workbook called "Two" with multiple worksheets (E,F,G,H).
I want to take worksheet A from workbook One and worksheets F and G from workbook Two. I wish to put these different worksheets in a new workbook called "Three."
My fields in worksheets A and F are in the exact same format, so I also wish to combine these two worksheets and put F data in the same fields under the A data, as soon as my cells containing A data finishes.
Could anyone help me with this code??
If anyone also has any links to VBA for beginners that would be highly appreciated.
Take a look at example:
'enforce declaration of variables
Option Explicit
Sub CombineWorkbooks()
Dim sWbkOne As String, sWbkTwo As String
Dim wbkOne As Workbook, wbkTwo As Workbook, wbkThree As Workbook
Dim wshSrc As Worksheet, wshDst As Worksheet
On Error GoTo Err_CombineWorkbooks
'get the path
sWbkOne = GetWbkPath("Open workbook 'One'")
sWbkTwo = GetWbkPath("Open workbook 'Two'")
'in case of "Cancel"
If sWbkOne = "" Or sWbkTwo = "" Then
MsgBox "You have to open two workbooks to be able to continue...", vbInformation, "Information"
GoTo Exit_CombineWorkbooks
End If
'open workbooks: 'One' and 'Two'
Set wbkOne = Workbooks.Open(sWbkOne)
Set wbkTwo = Workbooks.Open(sWbkTwo)
'create new one - destination workbook
Set wbkThree = Workbooks.Add
'define destination worksheet
Set wshDst = wbkThree.Worksheets(1)
'start copying worksheets
'A
Set wshSrc = wbkOne.Worksheets("A")
wshSrc.UsedRange.Copy wshDst.Range("A1")
'F
Set wshSrc = wbkTwo.Worksheets("F")
wshSrc.UsedRange.Copy wshDst.Range("A1").End(xlDown)
'G
Set wshSrc = wbkTwo.Worksheets("G")
wshSrc.UsedRange.Copy wshDst.Range("A1").End(xlDown)
'done!
Exit_CombineWorkbooks:
On Error Resume Next
Set wbkThree = Nothing
If Not wbkTwo Is Nothing Then wbkTwo.Close SaveChanges:=False
Set wbkTwo = Nothing
If Not wbkOne Is Nothing Then wbkOne.Close SaveChanges:=False
Set wbkOne = Nothing
Set wshDst = Nothing
Set wshSrc = Nothing
Exit Sub
Err_CombineWorkbooks:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_CombineWorkbooks
End Sub
Function GetWbkPath(ByVal initialTitle) As String
Dim retVal As Variant
retVal = Application.GetOpenFilename("Excel files(*.xlsx),*.xlsx", 0, initialTitle, , False)
If CStr(retVal) = CStr(False) Then retVal = ""
GetWbkPath = retVal
End Function
Note: Above code has been written ad-hoc, so it may not be perfect.
[EDIT2]
If you would like to copy data into different sheets, please, replace corresponding code with below, but firstly remove these lines:
'define destination worksheet
Set wshDst = wbkThree.Worksheets(1)
later:
'start copying data
'A
Set wshDst = wbkThree.Worksheets.Add(After:=wbkThree.Worksheets(wbkThree.Worksheets.Count))
wshDst.Name = "A"
Set wshSrc = wbkOne.Worksheets("A")
wshSrc.UsedRange.Copy wshDst.Range("A1")
'F
Set wshSrc = wbkTwo.Worksheets("F")
Set wshDst = wbkThree.Worksheets.Add(After:=wbkThree.Worksheets(wbkThree.Worksheets.Count))
wshDst.Name = "F"
wshSrc.UsedRange.Copy wshDst.Range("A1")
'G
Set wshSrc = wbkTwo.Worksheets("G")
Set wshDst = wbkThree.Worksheets.Add(After:=wbkThree.Worksheets(wbkThree.Worksheets.Count))
wshDst.Name = "G"
wshSrc.UsedRange.Copy wshDst.Range("A1")
Good luck!
I have the code that is used to copy the image from one worksheet and paste it on a new workbook.
My problem is that ' it works only if the image is attached within the range .i want the code that works even if the image is attached over the worksheet'.
Note : input file may contain's multiple image
My code is :
Set xlwbkinput = ActiveWorkbook
Set xlwbkoutput = Excel.Workbooks.Add
shtcountip = xlwbkinput.Sheets.Count
shtcountop = xlwbkoutput.Sheets.Count
If shtcountop < shtcountip Then
For i = shtcountop To shtcountip + 1
xlwbkoutput.Worksheets.Add After:=xlwbkoutput.Worksheets(xlwbkoutput.Worksheets.Count)
Next i
End If
For i = 1 To shtcountip 'it runs till the input workbook have the last sheet
xlwbkinput.Worksheets(i).Activate
xlwbkinput.Worksheets(i).Range("A1:AZ200").Copy 'here I'm copying input sheet
xlwbkoutput.Worksheets(i).Activate
xlwbkoutput.Worksheets(i).Paste 'here I'm pasting in my new worksheet
Next i
Thanks in Advance!!!!
The For loop below will iterate through all shapes in xlwbkinput.Worksheets(1) (which is the worksheet with index 1).
Then it checks if the current Shape (picture) cell position is larger then 1, which means it checks if the current picture's is positioned in any cell which starts from the 2nd row - you can easily modify that criteria.
Dim myPics As Shape
' loop through all shapes in Worksheets(1)
For Each myPics In xlwbkinput.Worksheets(1).Shapes
If myPics.TopLeftCell.Row > 1 Then ' check if current shape's row is larger than 1
myPics.Copy '<-- copy the current picture
End If
Next myPics
Give the following approach a try:
Option Explicit
Public Sub tmpSO()
Dim picIn As Picture
Dim picOut As Picture
Dim wksInput As Worksheet
Dim wksOutput As Worksheet
Dim cht As ChartObject
Set wksInput = ThisWorkbook.Worksheets("Sheet1")
Set wksOutput = ThisWorkbook.Worksheets("Sheet2")
For Each picIn In wksInput.Pictures
Set cht = wksInput.ChartObjects.Add(0, 0, picIn.Width, picIn.Height)
cht.Chart.Parent.Border.LineStyle = 0
picIn.Copy
cht.Chart.ChartArea.Select
cht.Chart.Paste
cht.Chart.Export Filename:=Environ("Temp") & "\someTempPicName.jpg", filtername:="JPG"
Set picOut = wksOutput.Pictures.Insert(Environ("Temp") & "\tmpPic5022.jpg")
picOut.Left = picIn.Left
picOut.Top = picIn.Top
cht.Delete
Kill Environ("Temp") & "\someTempPicName.jpg"
Next picIn
End Sub
This solution uses the worksheet.Pictures collection to iterate through all pictures on a sheet. The easiest way would be to simply .Copy and .Paste these pictures from one sheet to another. Yet, this approach would neglect the location of each picture on the sheet. Assuming that you want you pictures not randomly located on you output sheet, the above code will also copy the location from the input sheet.
I'm trying to get a single macro that I can assign to my command buttons. I have multiple buttons that open different files so in each cell I include a different file path.
Currently my command buttons are looking for a specific cell reference and opening that value.
Is there any way I can get the macro to look for the value in the cell to which it is aligned?
I'm using two macros at the moment - one to create the buttons and then another to assign to the buttons. I am having to create a new macro for each button.
Macro to create button...
Sub Buttons()
Dim i As Long
Dim lRow2 As Integer
Dim shp As Object
Dim dblLeft As Double
Dim dblTop As Double
Dim dblWidth As Double
Dim dblHeight As Double
With Sheets("Print Schedule")
dblLeft = .Columns("A:A").Left 'All buttons have same Left position
dblWidth = .Columns("A:A").Width 'All buttons have same Width
For i = Range("E65536").End(xlUp).Offset(1, 0) To ActiveCell + 15
dblHeight = .Rows(i).Height 'Set Height to height of row
dblTop = .Rows(i).Top 'Set Top top of row
Set shp = .Buttons.Add(dblLeft, dblTop, dblWidth, dblHeight)
shp.Characters.Text = "Open Print Schedule"
Next i
End With
End Sub
Macros to open file...
Sub Mendip()
Dim myfile As String
myfile = Cells(6, 6).Value
Application.Workbooks.Open Filename:=myfile
End Sub
Please tell me there is a better way to do this!
When you create the form buttons as shown below then you can assign a common macro to them
And you can assign a macro like this
Sub Sample()
Dim shp As Shape
Set shp = ActiveSheet.Shapes(Application.Caller)
'MsgBox shp.TopLeftCell.Address
Select Case shp.TopLeftCell.Address
Case "$A$1"
'~~> Do Something
Case "$B$1"
'~~> Do Something
'
'~~> And So on
'
End Select
End Sub
EDIT:
One thing I forgot to mention. To assign the "Sample" macro to all buttons, Add the below line after you create the shape.
shp.OnAction = "Sample"
I want to import data from multiple workbooks, all from the same sheet index (3).
I'm new to vba, and I figured out how to open multiple files up, and also to copy data from one sheet to another sheet in a different workbook for a single file, but I can't seem to figure out how to do that for multiple files.
I highlighted where the error is, it tells me "object doesn't support this property or method"
Could you please help?
Thanks
Sub dataimport()
' Set Vars
Dim ArbinBook As Workbook, DataBook As Workbook
Dim i As Integer, j As Integer
Dim Caption As String
Dim ArbinFile As Variant, DataFile As Variant
' make weak assumption that active workbook is the target
Set DataBook = Application.ActiveWorkbook
' get Arbin workbook
Caption = "Please select an input file"
' To set open destination:
' ChDrive ("E")
' ChDir ("E:\Chapters\chap14")
' With Application
'Set "arbinfile" as variant, the "true" at end makes it into an array
ArbinFile = Application.GetOpenFilename(, , Caption, , True)
'Exit when canceled
If Not IsArray(ArbinFile) Then
MsgBox "No file was selected."
Exit Sub
End If
Dim targetSheet As Worksheet
Set targetSheet = DataBook.Sheets(1)
'Open for every integer i selected in the array "arbinfile"
For i = LBound(ArbinFile) To UBound(ArbinFile)
Set ArbinBook = Workbooks.Open(ArbinFile(i))
targetSheet.Range("A2", "G150").Value = ArbinBook.Sheets(3).Range("A2", "G150").Value
**ERROR at the line above**
Workbooks(DataSheet).Activate 'Reactivate the data book
Worksheets(1).Activate 'Reactivate the data sheet
ActiveWorkbook.Sheets(1).Copy _
after:=ActiveWorkbook.Sheets(1)
Workbooks(ArbinFile(1)).Activate 'Reactivate the arbin book(i)
ArbinBook.Close
Next i
Beep
End Sub
My instinct tells me that ArbinBook.Sheets(3) is a Chart-sheet, not a WorkSheet (or, at least, it is something other than a WorkSheet). It might be hidden as well, but it will still be indexed as (3).
If so, change Sheets(3) to Worksheets(3).
Added: BTW If true, this also demonstrates why using index-numbers is unreliable. If at all possible, refer to a worksheet by its name. (I appreciate that this may not always be possible.)
Added (from comments) There is nothing named DataSheet in your code. Add Option Explicit to the top of your module to indicate all such errors.
Try changing the line Set ArbinBook = Workbooks.Open(ArbinFile(i))
to Set ArbinBook = Workbooks(arbinfile(i))
I could be wrong, but I think it's trying to set your workbook object to become the action of opening another workbook, instead of labeling it as the workboook.
Sub Multiple()
Application.DisplayAlerts = False
Application.EnableEvents = False
Dim exlApp As Excel.Application
Dim exlWb1 As Excel.Workbook
Dim exlWb2 As Excel.Workbook
Dim exlWb3 As Excel.Workbook
Dim exlWs1 As Excel.Worksheet
Dim exlWs2 As Excel.Worksheet
Dim exlWs3 As Excel.Worksheet
Set exlApp = CreateObject("Excel.Application")
Set exlWb1 = exlApp.Workbooks.Open("C:\yourpath1\file1.xls")
Set exlWb2 = exlApp.Workbooks.Open("C:\yourpath2\file2.xls")
Set exlWb3 = exlApp.Workbooks.Open("C:\yourpath3\file3.xls")
Set exlWs1 = exlWb.Sheets("Sheet1")
Set exlWs2 = exlWb.Sheets("Sheet1")
Set exlWs3 = exlWb.Sheets("Sheet1")
exlWb1.Activate
exlWb2.Activate
exlWb3.Activate
'code
exlWb.Close savechanges:=True
exlWb.Close savechanges:=True
exlWb.Close savechanges:=True
Set exlWs1 = Nothing
Set exlWs2 = Nothing
Set exlWs3 = Nothing
Set exlWb1 = Nothing
Set exlWb2 = Nothing
Set exlWb3 = Nothing
exlApp.Quit
Set exlApp = Nothing
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Is there a way when to make the current worksheet your on in excel to be the worksheet shown when changing worksheets in vb.net? Say I'm on worksheet 1 and change it to worksheet 2 through vb.net, If I enter in data it will show up on worksheet two but in order to see the data I have to physically go to the excel file and select worksheet 2 in order to change the actually worksheet page being displayed.
Tried this code and it seems to work on my side. The trick is the method sheet.Activate()
Sub Main
Dim excelApp as Microsoft.Office.Interop.Excel.Application = _
new Microsoft.Office.Interop.Excel.Application()
Try
Dim inFile As String = "D:\temp\test.xls"
' Show excel '
excelApp.Visible = true
Dim excelWorkbook As Microsoft.Office.Interop.Excel._Workbook = _
excelApp.Workbooks.Open(infile)
Dim x as Integer
for x = excelApp.Sheets.Count to 1 step -1
Dim sheet as _Worksheet = CType(excelApp.Sheets(x), _Worksheet)
sheet.Activate() ' Activate the sheet'
Thread.Sleep(5000) ' Sleep for 5 seconds to see the sheet'
Next
Finally
if excelApp IsNot Nothing then
excelApp.DisplayAlerts = false
'excelApp.Quit(); 'remove the comment to close excel'
End if
End try
End Sub