Hi I have the following Code:
Sub test()
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Dim rng As Range
Cells(2, 7).Value = Cells(2, 7).Value
Set rng = ActiveSheet.Cells(2, 7)
Set objData = New DataObject
sHTML = rng.Text
objData.SetText sHTML
objData.PutInClipboard
ActiveSheet.PasteSpecial Format:="Unicode Text"
End Sub
However I was wondering if there is a way to use this method:
ActiveSheet.PasteSpecial Format:="Unicode Text"
In some sort of a way where I define the Paste range as well. It seems the text which is being pasted is copied in multiple cells overwriting other ones.
You could paste it to the currently selected cell, which can be very intuitive and useful for the end user:
Selection.PasteSpecial Format:="Unicode Text"
If you want to define the location in the code then you could do something like this:
Range("A1").PasteSpecial Format:="Unicode Text"
Edit: Today I learned that Range.PasteSpecial is different from Worksheet.PasteSpecial.
It looks like you can choose where you want to paste the data by selecting the cell before attempting to paste. This appears to do the trick for me:
Sub test()
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Dim rng As Range
Cells(2, 7).Value = Cells(2, 7).Value
Set rng = ActiveSheet.Cells(2, 7)
Set objData = New DataObject
sHTML = rng.Text
objData.SetText sHTML
objData.PutInClipboard
rng.Select '<----Add this line.
ActiveSheet.PasteSpecial Format:="Unicode Text"
End Sub
I found this to work:
Private Sub Worksheet_Activate()
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Dim rng As Range
Cells(1, 7).Value = Cells(1, 7).Value
Set rng = ActiveSheet.Cells(1, 7)
Set objData = New DataObject
sHTML = rng.Text
objData.SetText (sHTML)
objData.PutInClipboard
rng.Select
Worksheets("GridData").Range("G1").Select
ActiveSheet.PasteSpecial Format:= _
"Unicode Text"
End Sub
Related
I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
I have a problem with my code. It does the trick of copy/paste correctly. However, I think there is something tricky. When I try to update my dynamic table it displays a message that the WB I'm currently working in already has data and if I want to replace it. When I choose "Yes/No" it immediately displays another column in my table that says that 81 registers are not been used in UTILITY. When I do everything by hand there are no problems. So, I guess there´s something wrong with my macro.
Option Explicit
Sub DailyTrans_MDM()
Call CopyPaste
End Sub
Sub CopyPaste()
Dim vFile As Variant
Dim folderPath As String
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
vFile = Dir(folderPath & "*.xl*")
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
Do While vFile <> ""
Application.ScreenUpdating = False
vFile = Application.GetOpenFilename("Daily Reports (*.xl*)," & "*.xl*", 1, "Select Report", "Open File", False)
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets("ReporteCifrasControl")
End If
'--------------------------------------------------------------------------------------
wsCopyFrom.Range("A2:M" & wsCopyFrom.Range("A" & Rows.Count).End(xlUp).row).Copy
wsCopyTo.Range("A" & wsCopyTo.Range("A" & Rows.Count).End(xlUp).row + 1).PasteSpecial xlPasteValuesAndNumberFormats
wbCopyFrom.Close SaveChanges:=False
Dim rngCopy As Range, rngPaste As Range
With ActiveSheet
Set rngCopy = .Range(.Range("A2"), Cells(2, Columns.Count).End(xlToLeft))
Set rngPaste = .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)).Resize(, rngCopy.Columns.Count)
End With
rngCopy.Copy
rngPaste.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Loop
End Sub
I believe you want to do this
Copy row 2 from Column A to Last Used Column (LC)
Paste this in the first Non-Used Row (LR) in Column A
Dim LC As Long
Dim LR As Long
With ActiveSheet
LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
LR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngCopy = .Range(.Cells(1, 2), .Cells(LC, 2))
Set rngPaste = .Range("A" & LR)
End With
rngCopy.Copy
rngPaste.PasteSpecial xlPasteFormats
You missed some objects to be qualified in your code. No point in using the With Block if you are not going to use the With Block
Just realized you have multiple copy/pastes in your code. If this is the wrong one, use the format here to modify the other one.
The code below is a web page table scraper that I am using and it works nicely. It currently only opens the hyperlink that is in location 'L4' using .Open "GET", Range("L4"), False
Sub ImportData()
'Objects
Dim htm As Object
Dim Tr As Object
Dim Td As Object
Dim Tab1 As Object
'Create HTMLFile Object
Set HTML_Content = CreateObject("htmlfile")
'Get the WebPage Content to HTMLFile Object
On Error GoTo Error
With CreateObject("msxml2.xmlhttp")
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
.send
HTML_Content.body.innerHTML = .responseText
End With
On Error GoTo Error
'Add New Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "ESTIMATE"
'Set table variables
Column_Num_To_Start = 1
iRow = 2
iCol = Column_Num_To_Start
iTable = 0
'Loop Through Each Table and Download it to Excel in Proper Format
For Each Tab1 In HTML_Content.getElementsByTagName("table")
With HTML_Content.getElementsByTagName("table")(iTable)
For Each Tr In .Rows
For Each Td In Tr.Cells
Sheets(2).Cells(iRow, iCol).Select
Sheets(2).Cells(iRow, iCol) = Td.innerText
iCol = iCol + 1
Next Td
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tr
End With
iTable = iTable + 1
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tab1
'Success
'Loop to find authorised hours string
Dim rng1 As Range
Dim strSearch As String
strSearch = "Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
'Add Value to Sheet1
Sheets(1).Range("E4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("E4").Value = 0
End If
strSearch = "Actual Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("D4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("D4").Value = 0
'Move on to next
End If
strSearch = "Name"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("J4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("J4").Value = "NULL"
End If
'Scrape Description
Dim desc As String
HTML_Content.getElementsByTagName ("div")
desc = HTML_Content.getElementsByTagName("p")(0).innerText
Sheets(1).Range("K4").Value = desc
'Keep Sheet 1 Open
Sheets(1).Activate
'Delete ESTIMATE Sheet
Application.DisplayAlerts = False
Sheets(2).Delete
Application.DisplayAlerts = True
Error:
End Sub
The starting row of the hyperlink is L4, how could I make a loop that cycles through all links located in the L column and runs this script for each hyperlink that is in column L? How would I make a variable to so that Range will know what row is currently being processed?
Could I put my code into something like this:
For Each i In Sheet1.Range("L4:L200")
' code here
Next i
Any help is much appreciated, thank you.
change
Sub ImportData()
...
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
...
into
Sub ImportData(urlToOpen as string)
...
.Open "GET", urlToOpen, False 'Cell that contains hyperlink
...
and add a calling procedure:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i)
Next i
end sub
UPDATE 1
To get data from the procedure you might either send it back into the main procedure or you prepare a place prior to calling the procedure:
either:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i, returnValue)
i.offset(0,1).value = returnValue
Next i
end sub
Sub ImportData(urlToOpen as string, returnValue as string)
...
'returnValue = Data you want to give back
returnValue = DataSource...(I didn't read your code again ;-)
...
or:
Sub CallRangeL_Urls
Dim targetRange as Range
For Each i In Sheet1.Range("L4:L200")
' code here
sheets.add after:=sheets(1)
'set a link on the sheet
Range("A1").value = i
Set targetRange = Range("A3")
call ImportData(i, targetRange)
Next i
end sub
Sub ImportData(urlToOpen as string, target as range)
...
'Save whatever data to the new sheet
target.offset(0,0).value = datavalue1 'Range("A3")
target.offset(1,0).value = datavalue1 'Range("A4")
target.offset(2,0).value = datavalue1 'Range("A5")
...
UPDATE 2
UPDATE 2: single data items (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim Sheet1 As Worksheet
Dim returnValue As String
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
' code here
Debug.Print "url: "; iCell.Value
Call ImportData(iCell.Value, returnValue)
iCell.Offset(0, 1).Value = returnValue
Debug.Print returnValue
Next iCell
End Sub
Sub ImportData(urlToOpen As String, ByRef returnValue As String)
'...
'returnValue = Data you want to give back
returnValue = "This is the data we get back from yourUrl: " & urlToOpen & " - DATA/DATA/DATA" 'DataSource...(I didn't read your code again ;-)
End Sub
Immediate window:
url: www.google.de
This is the data we get back from yourUrl: www.google.de - DATA/DATA/DATA
UPDATE 2: data on result sheet(s) (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim targetRange As Range
Dim Sheet1 As Worksheet
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
'create a new "RESULTS" sheets
Sheets.Add after:=Sheets(1)
Debug.Print "New sheet created: " & ActiveSheet.Name
'set a link on the sheet
Range("A1").Value = iCell.Value 'leave a copy of the url on the sheet as a reference
Set targetRange = Range("A3") 'here we want to get the results
Call ImportData(iCell.Value, targetRange)
Next iCell
End Sub
Sub ImportData(urlToOpen As String, target As Range)
Dim datavalue1, datavalue2, datavalue3
'...
datavalue1 = "data value 1"
datavalue2 = "data value 2"
datavalue3 = "data value 3"
'Save whatever data to the new sheet
target.Offset(0, 0).Value = datavalue1 'Range("A3")
target.Offset(1, 0).Value = datavalue2 'Range("A4")
target.Offset(2, 0).Value = datavalue3 'Range("A5")
Debug.Print "datavalues stored on sheet: " & target.Parent.Name
'...
End Sub
Immediate window:
New sheet created: Sheet2
datavalues stored on sheet: Sheet2
I made a nice Excel file with several (almost the same) macros. Goal is to fill open a Word template, fill in the bookmarks and save every individual document with predefined fields in the filename. Works like a charm... but it doesn't go further then the 10th row of my Excel file. All 12 macros have the same issue, basically the macro is the same only the fields are different.
The VBA I have now is this:
Option Explicit
Sub Akkoordverklaring()
Dim lonLaatsteRij As Long
Dim rngData As Range
Dim strVoornaam As String, strAchternaam As String, strSlber As String
Dim c As Range
With Sheets("Cijferlijst")
lonLaatsteRij = .Cells(Rows.Count, "A").End(xlUp).Row
Set rngData = .Range(.Cells(2, 1), .Cells(lonLaatsteRij, 1))
End With
For Each c In rngData
strVoornaam = c.Value
strAchternaam = c.Offset(0, 1).Value
strSlber = c.Offset(0, 12).Value
Call maakWordDocument(strVoornaam, strAchternaam, strSlber)
Next c
End Sub
Private Sub maakWordDocument(strVoornaam As String, strAchternaam As String, _
strSlber As String)
Dim wordApp As Object, WordDoc As Object
On Error Resume Next
Set wordApp = GetObject("", "Word.Application")
If wordApp Is Nothing Then
Set wordApp = CreateObject("Word.Application")
End If
wordApp.Visible = False
Set WordDoc = wordApp.Documents.Open(ThisWorkbook.Path & _
"Formulieren\Akkoordverklaring.docx")
Call InvullenBladwijzer(wordApp, "voornaam", strVoornaam)
Call InvullenBladwijzer(wordApp, "achternaam", strAchternaam)
Call InvullenBladwijzer(wordApp, "slber", strSlber)
wordApp.DisplayAlerts = False
WordDoc.SaveAs Filename:=ThisWorkbook.Path & _
"Akkoordverklaring\Akkoordverklaring " & strVoornaam & Space(1) & _
strAchternaam, FileFormat:=wdFormatDocumentDefault
WordDoc.Close
wordApp.Quit
Set WordDoc = Nothing
Set wordApp = Nothing
End Sub
Sub InvullenBladwijzer(wordApp As Object, strBladwijzer As String, _
strTekst As String)
wordApp.Selection.Goto What:=wdGoToBookmark, Name:=strBladwijzer
wordApp.Selection.TypeText strTekst
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
As I'm not a programmer I just know how to read some VBA. Some users in here also helped me out with the VBA above:
Excel: change VBA action frome same sheet to another sheet
I know this has been raised many times (often under Run-time error '1004') but I am having difficulties isolating the error in my code - despite extensive research both here and other sites. My code runs from a command button on an Access form and runs successfully the first time after opening the form, but fails on subsequent attempts. I think I am using inadequate references and/or opening a second Excel object but I can't work out how.
Other formatting is carried out, but I have removed as much as possible to keep it short.
Private Sub cmdExport_Click()
Dim dbs As Database
Dim rst As DAO.Recordset
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim lngCount As Long
Dim lngDataRows As Long
Dim intLoop As Integer
Dim strSheetName As String
Dim dteStart As Date
Dim dteEnd As Date
Dim curStartBal As Currency
Dim intMoves As Integer
Dim lngCol As Long
Dim lngRow As Long
Dim intField As Integer
Dim intFieldCount As Integer
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim blnFileCheck As Boolean
strFile = "BudgetForecast.xlsx"
strPath = genFindFolder("tblSettings") 'provides path to data store
strPathFile = strPath & strFile
blnFileCheck = genDeleteFile(strPath, strFile) 'Deletes existing file if it exists
dteStart = DateAdd("m", 1, Date)
dteEnd = DateAdd("m", 12, Date)
strSheetName = "Forecast " & MonthName(Month(dteStart), True) & " " & CStr(Year(dteStart)) 'Start Month and Year
strSheetName = strSheetName & " To " & MonthName(Month(dteEnd), True) & " " & CStr(Year(dteEnd)) 'Add End Month and Year
curStartBal = [Forms]![frmBudForecast]![txtStart1]
'Create new Excel Workbook and add data
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("qryBudForecastFinal")
Set appExcel = New Excel.Application
Set wbk = appExcel.Workbooks.Add
Set wks = wbk.ActiveSheet
appExcel.Visible = True
With wks
.Name = strSheetName
.Cells(1, 1).Value = "Sort"
.Cells(1, 2).Value = "Date"
.Cells(1, 3).Value = "Type"
.Cells(1, 4).Value = "Account"
.Cells(1, 5).Value = "Payee/Details"
.Cells(1, 6).Value = "Jan"
' lines for Feb to Nov removed to shorten extract
.Cells(1, 17).Value = "Dec"
.Cells(1, 18).Value = "Totals"
rst.MoveLast
rst.MoveFirst
lngCount = rst.RecordCount
intFieldCount = rst.Fields.Count
lngDataRows = lngCount + 5
rst.MoveFirst
Do Until rst.EOF
lngCol = 1
lngRow = .[A65536].End(3).Row + 1
For intField = 0 To intFieldCount - 1
.Cells(lngRow, lngCol) = rst.Fields(intField).Value
lngCol = lngCol + 1
Next intField
rst.MoveNext
Loop
'Shift columns around to correct order
If Month(Date) <> 12 Then 'If December, records are already in correct order
intMoves = Month(Date)
For intLoop = 1 To intMoves
.Columns("R:R").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '###Error here
.Columns("F:F").Select
Selection.Cut Destination:=Columns("R:R")
.Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Next intLoop
End If
End With
'Save new file (next line commented-out for testing)
'appExcel.ActiveWorkbook.SaveAs FileName:=strPathFile, ConflictResolution:=xlOtherSessionChanges
'Close Excel
appExcel.ActiveWindow.Close (False)
'Cleanup
rst.Close
Set rst = Nothing
Set dbs = Nothing
Set wks = Nothing
Set wbk = Nothing
appExcel.Quit 'Not sure if this line is necessary
Set appExcel = Nothing
End Sub
Error occurs on this line:
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
and 'Selection' appears to be 'Nothing'.
I've tried all sorts of variations and amendments to the syntax - I suspect I need to be more specific with the selection of column R, but I don't know how. Incidentally, when the code fails, column R on the spreadsheet is selected.
I'm tempted just to hide the command button on the form after it has been clicked, but fear this would be a cop-out and certainly wouldn't help my understanding.
appExcel.Selection
Selection is not part of the Access object model. But you should try to avoid using select/activate where possible. For example:
.Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
would be better written as:
.Columns("F:F").Delete Shift:=xlToLeft
How to avoid using Select in Excel VBA