My goal is to copy a multiline formatted text from Word to an Excel worksheet into one single cell using a VBA macro.
Now I've got a multiline text which needs two cells.
This is my current code:
With oWB.Worksheets("EPICS")
' Insert DESCRIPTION - todo
'
' HEADING xyz is selected, move one down and go to Pos1
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.HomeKey Unit:=wdLine
' Save current line number (BEGIN)
BeginText = Selection.Range.Information(wdFirstCharacterLineNumber)
' Go to the first table and one move up
Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext, Count:=1, Name:=""
Selection.MoveUp Unit:=wdLine, Count:=1
' Save current line number (END)
EndText = Selection.Range.Information(wdFirstCharacterLineNumber)
RangeToSelect = EndText - BeginText
Selection.MoveUp Unit:=wdLine, Count:=RangeToSelect, Extend:=wdExtend
Selection.Copy
.Cells(1, 1).PasteSpecial xlPasteValues
End With
This creates the following:
I would like to have the following:
Any ideas how I can handle this or any input?
Instead of
...
Selection.Copy
.Cells(1, 1).PasteSpecial xlPasteValues
...
Code
.Cells(1, 1).Value=Selection.text
Related
I'm just getting familiar with VBA and my code
For k = 3 To ThisWorkbook.Sheets.Count
ThisWorkbook.Sheets(k).Activate
ActiveSheet.Cells(11, 2).Select
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("A5:" & "A" & CStr(lLastRow)).Copy
' ThisWorkbook.Sheets(1).Cells("B" & CStr(lFirstRow) & ":B" & CStr(lLastRow)).Select
ThisWorkbook.Sheets(1).Activate
ActiveSheet.Cells(lFirstRow, 2).Select
Selection.Paste
'Selection.PasteSpecial Paste:=xlPasteValues
'Selection.PasteSpecial Paste:=xlPasteFormats
lFirstRow = lFirstRow + lLastRow
Next k
makes "Run-time error 438. Object doesn't support this porperty or method" to appear when the line "Selection.Paste" goes. What's the problem?:(
I've tried to use paste special, to activate sheet and to select cell (not range), to use Cstr, but nothing changed
Try Selection.PasteSpecial xlPasteAll
Paste by itself works on several objects, most notably Worksheet but not on a Range object which is what your Selection is.
To paste to a Range you really have to use the PasteSpecial method with its' available arguements such as xlPasteAll; xlPasteValues; xlPasteFormulas; xlPasteFormats and others which you can see by pressing F1 while the cursor is within PasteSpecial in the VBE.
Replace these two lines in your code
ActiveSheet.Cells(lFirstRow, 2).Select
Selection.Paste
by
Cells(lFirstRow, 2).Select
Activesheet.paste
your code will work flawlessly
Important note for working with paste and pastespecial in vba
Copy any range from anywhere then
Paste Special method (Sheets.Cells/Range.PasteSpecial)
Sheets ("Daily Shortage").Activate
Sheets ("Daily Shortage").Cells (m, 1). PasteSpecial Paste: = xlPasteValues
One Example –
Will throw error
Sheets ("June"). Range ("A10").Select
ActiveSheet.PasteSpecial Paste: = xlPasteValues
This will work flawlessly
Sheets ("June"). Range ("A10").PasteSpecial Paste: = xlPasteValues
Paste method (ActiveSheet.Paste)
Sheets ("June"). Range ("A10").Select
ActiveSheet.Paste
I have created a table called "valtable2" and I am trying to delete the text in one of the cells.
With valtable2
.Cell(2, 1).Select
Selection.Delete
End With
With valtable2
.Cell(2, 1).Select
Selection.Delete
End With
The cell is being selected, but it doesn't delete.
Try to avoid using Select where possible. You could just set the cell value to nothing:
valtable2.Cell(2, 1).Range.Text = ""
I created this VBA Code but it does not loop through each worksheet as I want it to. I just perform the task on the active worksheet.
Could someone help me out?
Public Sub MvColumns()
Dim i As Long
For i = 2 To ThisWorkbook.Worksheets.Count
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("F:F").Select
Selection.Cut Destination:=Columns("D:D")
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("G:G").Select
Selection.Cut Destination:=Columns("J:J")
Columns("H:H").Select
Selection.Cut Destination:=Columns("G:G")
Columns("H:J").Select
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("A:F").Select
Columns("A:F").EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 18.43
Range("C4").Select
Range("A2").ClearContents
Next
End Sub
code here
You need to watch this video series: Excel VBA Introduction - YouTube. This is the most relavent: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)
Public Sub MvColumns()
Dim i As Long
For i = 2 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Worksheets(i)
.Columns("D").Insert Shift:=xlToRight
.Columns("F").Cut Destination:=Columns("D:D")
.Columns("F").Delete Shift:=xlToLeft
.Columns("G").Cut Destination:=Columns("J:J")
.Columns("H").Cut Destination:=Columns("G:G")
.Columns("H:J").Delete Shift:=xlToLeft
.Columns("A").Delete Shift:=xlToLeft
.Columns("A:F").EntireColumn.AutoFit
.Columns("A").ColumnWidth = 18.43
.Range("A2").ClearContents
End With
Next
End Sub
Replace your Dim and For lines with:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
That should accomplish what you're asking -- but if you like, you could also clean up unnecessary parts of your code (and speed it up slightly) like this:
Public Sub MvColumns()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Columns("D").Insert Shift:=xlToRight
ws.Columns("F").Cut Destination:=Columns("D")
ws.Columns("F").Delete Shift:=xlToLeft
ws.Columns("G").Cut Destination:=Columns("J")
ws.Columns("H").Cut Destination:=Columns("G")
ws.Columns("H:J").Delete Shift:=xlToLeft
ws.Columns("A").Delete Shift:=xlToLeft
ws.Columns("A:F").EntireColumn.AutoFit
ws.Columns("A").ColumnWidth = 18.43
ws.Range("A2").ClearContents
Next
End Sub
Your code just perform the task on the active sheet because by default
Columns("D:D").Select
and the other lines are applied to the active sheet.
To apply a task to a selected sheet you have to prefix your code by using "With" like this
With ThisWorkbook.Sheets("MyWantedSheet")
.Columns("D:D").Select 'the dot link your code with "MyWantedSheet"
Selection.Insert Shift:=xlToRight
'your entire code
End With
In your case, you're using a loop so you can do that :
For each sheet in ThisWorkbook.Worksheets ' loop over all sheets
With sheet 'select the sheet and apply task on it
.Columns("D:D").Select
Selection.Insert Shift:=xlToRight
'your entire code
End With
Next
I would like to loop through column A in Worksheet1 and find the first cell which has a specified text "Oil Production". This cell is the first cell in the array I wish to copy to Worksheet2. This cell and the size of the array will change from time to time, hence the code I have used. I then paste it into cell B7 in Worksheet2 which will never change.
This is my formula. I get the error at line ActiveSheet.Paste
Sub Test()
Application.ScreenUpdating = False
For Each Cell In Sheets("Sheet1").Range("A:A")
If Cell.Value = "Oil Production" Then
ActiveSheet.Cells.Select
Range(ActiveCell, Cells(ActiveCell.End(xlDown).Row, ActiveCell.End(xlToRight).Column)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B7").Select
ActiveSheet.Paste
End If
Next
End Sub
resize the area:
Sub Test()
Dim MyRowCount As Long, MyColCount As Long
Application.ScreenUpdating = False
For Each Cell In Sheets("Sheet1").Range("A1:A" & Range("A" & Rows.count).end(xlup).row) 'This make it poll the used data rather than the whole column
If Cell.Value = "Oil Production" Then
ActiveSheet.Cells.Select
With Range(ActiveCell, Cells(ActiveCell.End(xlDown).Row, ActiveCell.End(xlToRight).column))
.Copy
MyRowCount = .Rows.Count
MyColCount = .Columns.Count
End With
Sheets("Sheet2").Select
Range("B7").Resize(MyRowCount, MyColCount).PasteSpecial xlPasteAll
'Do you need to flick back to Sheet1 after pasting?
End If
Next
End Sub
Also I took out a bunch of selects for you.
Range("A1").Select
Selection.Paste
can be written as
Range("A1").PasteSpecial XLPasteAll
You can chop out most selects this way, you can see I have also done it with the Range you are copying
I am a VBA newb and am having an extremely difficult time trying to write some code for this solution. Any help would be greatly appreciated!
Within MS Word, I need to look in one Excel workbook across a worksheet and copy/paste the data that fits my criteria into a two-column table:
Start in Row 6 of the worksheet, look within range D6:M6. If D6:M6 is blank, then go to the next row. If any cell in D6:M6 has data, copy the data from C6 and paste it in the first row of a table (preferably merged across two columns). Then, copy the data from Row 1 of the column that has data and paste it into the table's next row (1st column). Then, copy the data from the cell that has data and paste that into the 2nd column.
Basically, if there is data, the first row of a table will come from column C of the row that has data, the next row's first column will come from Row 1 of the column that has data, and the 2nd column of the second row will come from the cell that has data within that same column.
Thank you for offering to help. Here's a hyperlink to a sample Excel file, and the very Amateurish code I've started to write within MS Word that only covers the first product:
Excel Sample File
Private Sub useVBinWord()
Dim workBook As workBook
Dim dataInExcel As String
Application.ScreenUpdating = False
Selection.TypeText Text:="Comments:"
Selection.TypeParagraph
Selection.TypeText Text:="Printed: " & Now
Selection.TypeParagraph
Set workBook = Workbooks.Open("C:\Users....xls", True, True)
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=100, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
dataInExcel = workBook.Worksheets("Top30 Comments").Range("C6").Formula
ActiveDocument.Tables(1).Cell(1, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("D1").Formula
ActiveDocument.Tables(1).Cell(2, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("D6").Formula
ActiveDocument.Tables(1).Cell(2, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("E1").Formula
ActiveDocument.Tables(1).Cell(3, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("E6").Formula
ActiveDocument.Tables(1).Cell(3, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("F1").Formula
ActiveDocument.Tables(1).Cell(4, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("F6").Formula
ActiveDocument.Tables(1).Cell(4, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("G1").Formula
ActiveDocument.Tables(1).Cell(5, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("G6").Formula
ActiveDocument.Tables(1).Cell(5, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("H1").Formula
ActiveDocument.Tables(1).Cell(6, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("H6").Formula
ActiveDocument.Tables(1).Cell(6, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("I1").Formula
ActiveDocument.Tables(1).Cell(7, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("I6").Formula
ActiveDocument.Tables(1).Cell(7, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("J1").Formula
ActiveDocument.Tables(1).Cell(8, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("J6").Formula
ActiveDocument.Tables(1).Cell(8, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("K1").Formula
ActiveDocument.Tables(1).Cell(9, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("K6").Formula
ActiveDocument.Tables(1).Cell(9, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("L1").Formula
ActiveDocument.Tables(1).Cell(10, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("L6").Formula
ActiveDocument.Tables(1).Cell(10, 2).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("M1").Formula
ActiveDocument.Tables(1).Cell(11, 1).Select
Selection.TypeText Text:=dataInExcel
dataInExcel = workBook.Worksheets("Top30 Comments").Range("M6").Formula
ActiveDocument.Tables(1).Cell(11, 2).Select
Selection.TypeText Text:=dataInExcel
workBook.Close True
Set workBook = Nothing
Application.ScreenUpdating = True
End Sub
You've picked a difficult project to start with! Here's my almost complete solution :
Sub ImportTable()
Dim AppExcel As Excel.Application ' link to Excel
Dim ExcelRange As Excel.Range ' range in worksheet to process
Dim ExcelData As Variant ' worksheet data as VBA array
Dim ExcelHeadings As Variant ' worksheet headings as VBA array
Dim FoundCol As Boolean ' a column found with data ***
Dim exCol As Integer ' Excel column (iterator)
Dim exRow As Integer ' Excel row (iterator)
Dim wdRow As Integer ' Word table row
' reference to open instance of Excel
Set AppExcel = GetObject(class:="Excel.Application")
' change this to create an instance and open the file
Set ExcelRange = AppExcel.ActiveSheet.UsedRange ' the spreadsheet data as a range
' change this to ensure we have the correct worksheet
' the following reads cells C6 to End into a VBA array (row,column)
ExcelData = ExcelRange.Offset(5, 2).Resize(ExcelRange.Rows.Count - 6, _
ExcelRange.Columns.Count - 2)
' the following reads the heading row starting at C1
ExcelHeadings = ExcelRange.Offset(0, 2).Rows(1)
' assumes we have a blank document in word
With ActiveDocument.Range
.InsertAfter "Comments:" & vbCrLf ' insert your document header
.InsertAfter "Printed: " & Now & vbCrLf & vbCrLf
End With
Selection.EndOf wdStory ' reposition selection at end
ActiveDocument.Tables.Add Selection.Range, 1, 2 ' create a 1 x 2 table
With ActiveDocument.Tables(1) ' use this table
.Style = "Table Grid" ' set the style (copied from your code)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
' the first row is left blank for you to insert a title
' perhaps you should make this row repeat on each page
wdRow = 2 ' we will fill from row 2 which doesn't exist yet
For exRow = 1 To UBound(ExcelData, 1) Step 3 ' process every 3rd row
FoundCol = False ' mark 'not found' ***
For exCol = 2 To UBound(ExcelData, 2) ' test each column from D
If Trim(ExcelData(exRow, exCol)) <> "" Then ' if cell not empty
If Not FoundCol Then ' first filled column, write header
.Rows.Add ' add row for header
.Rows.Add ' add row for data (avoid problem with merged row)
.Rows(wdRow).Cells.Merge ' merge header row
.Rows(wdRow).Range.InsertAfter ExcelData(exRow, 1) ' add title from C
' this keeps the two rows together across page breaks
.Rows(wdRow).Range.ParagraphFormat.KeepWithNext = True
wdRow = wdRow + 1 ' row added
FoundCol = True ' header written
Else
.Rows.Add ' add row for data
' this keeps the two rows together across page breaks
.Rows(wdRow - 1).Range.ParagraphFormat.KeepWithNext = True
End If
' write heading from row 1
.Cell(wdRow, 1).Range.InsertAfter ExcelHeadings(1, exCol)
' write found data
.Cell(wdRow, 2).Range.InsertAfter ExcelData(exRow, exCol)
wdRow = wdRow + 1 ' row added
End If
Next exCol
Next exRow
End With
' don't forget to close the instance of Excel
End Sub
Read the comments, I've left you a bit of work to do!