I have a document with a text in a table of two columns, and i want to make a macro that equals two paragraphs in both columns.
I'm doing this thru checking the location of first character in each paragraph relative to page using range.information(wdVerticalPositionRelativeToPage), and then comparing it to the same paragraph in the other column and adding the difference to the Paragraphs.SpaceBefore of the upper paragraph.
my problem is: that it's not doing it exactly, it's still not having a small gap between the paragraphs in both columns.
is there any way to make this process a little more exact?
here is my macro:
Sub EqualColumns()
Dim EnRange As Range, EnCh As Range
Dim YiRange As Range, YiCh As Range
Dim PaCount As Long
Set YiRange = Selection.Tables(1).Columns(1).Cells(2).Range
Set EnRange = Selection.Tables(1).Columns(2).Cells(2).Range
' paregraphes
set pacount = EnRange.Paragraphs.Count
For MyLoop = 1 To pacount
Set EnPa = EnRange.Paragraphs(MyLoop).Range
Set EnCh = EnPa.Characters(1)
EnPo = EnCh.Information(wdVerticalPositionRelativeToPage)
Set YiPa = YiRange.Paragraphs(MyLoop).Range
Set YiCh = YiPa.Characters(1)
YiPo = YiCh.Information(wdVerticalPositionRelativeToPage)
If EnPo > YiPo Then
MyAm = EnPo - YiPo
YiRange.Paragraphs(MyLoop).SpaceBefore = YiRange.Paragraphs(MyLoop).SpaceBefore + MyAm
ElseIf EnPo < YiPo Then
MyAm = YiPo - EnPo
EnRange.Paragraphs(MyLoop).SpaceBefore = YiRange.Paragraphs(MyLoop).SpaceBefore + MyAm
End If
Next
End Sub
Related
I would like to paste data from a range, copy it in a new range.
This new range is supposed to count up its row by +1 (represented by variable i)
for each value (self) that is being pasted.
I use self, because i need to extract values from a range that includes empty cells.
I tested the first part, the debug print works, so the self values are obtained correctly.
I must be making a mistake with the Range(27, i) part, and also with the Set i = 15 part.
Help very appreciated.
sincerely
Private Sub EvaluateButton_Click()
Dim EvaRange As Range 'Evaluation range
Dim i As Integer 'Counter for free columns
Worksheets("testsheet").Activate
Set EvaRange = Range("C10:C999")
EvaRange.Copy Range("Z15")
Range("Z15:Z999").Select
Set i = 15
For Each self In Selection.SpecialCells(xlCellTypeConstants)
Debug.Print (self)
i = i + 1
self.Copy Range(27, i)
Next
End Sub
Edit: i tried a second version, i think that variables are defined like this:
Dim x As Integer
x = 6
So shouldn't this work?
Private Sub EvaluateButton_Click()
Dim EvaRange As Range
Dim i As Integer
Worksheets("testsheet").Activate
Set EvaRange = Range("C10:C999")
EvaRange.Copy Range("Z15")
Range("Z15:Z999").Select
i = 15
For Each self In Selection.SpecialCells(xlCellTypeConstants)
Debug.Print (self)
self.Copy Range(27, i)
i = i + 1
Next
This will remove my empty lines :)
Now, I have the problem, that my last value is duplicated down the line, a new challenge to handle :)
Private Sub EvaluateButton_Click()
Dim EvaRange As Range 'Evaluation range
Dim i As Integer 'Counter for free columns
Worksheets("testsheet").Activate
Set EvaRange = Range("C10:C999")
EvaRange.Copy Range("Z15")
Range("Z15:Z999").Select
i = 15
For Each self In Selection.SpecialCells(xlCellTypeConstants)
Debug.Print (self)
self.Copy Cells(i, 27)
i = i + 1
Next
I have the following requirement in my LibreOffice Calc spreadsheet:
ForEach Row 'r' in selected range,
starting from the last row in the range,
and moving backwards (up) one row at a time,
do some cell value comparisons, and based on that, either skip the row,
or set some cell values, and delete the selected row,
then proceed with the same process, with the row just above that.
ie.,
Representing CellValue(Column[A], Row[r])
as A[r],
And Representing the row before (just above) that,
as A[r-1],
I need to do the following:
FOR (r = LastRowInSelectedRange; r>1; r=r-1) {
IF FollowingConditionsAreTrue (
(r > 1)
AND (A[r] IsEqualTo A[r-1])
AND (B[r] IsEqualTo C[r-1])
AND (E[r] IsEqualTo E[r-1])
) ThenDoTheFollowing {
SET C[r-1] = C[r]
DeleteRow(r)
} EndIF
} EndFOR
Question:
How can we implement this in LibreOffice Calc?
The following should do the trick. It assumes your data are in the range A1:E10 in a sheet called Sheet1. To use a different range change the appropriate lines. If you want to select the range by hand, comment out the line oCellRange = oSheet.getCellRangeByName("A1:E10") and uncomment the line oCellRange = oDoc.getCurrentSelection(). That will only work if you have a single selection, not multiple ones.
Sub iterateThroughRange()
Dim oDoc As Object
oDoc = ThisComponent
Dim oSheet As Object
oSheet = oDoc.getSheets().getByName("Sheet1")
Dim oCellRange As Object
oCellRange = oSheet.getCellRangeByName("A1:E10")
'The above line gets a named range. To get a slected area instead
'comment it out and uncomment the following line:
'oCellRange = oDoc.getCurrentSelection()
Dim oTableRows As Object
oTableRows = oCellRange.getRows()
Dim nRows As Integer
nRows = oTableRows.getCount()
Dim oTableColumns As Object
oTableColumns = oCellRange.getColumns()
Dim nColumns As Integer
nColumns = oTableColumns.getCount()
Dim oThisRow As Object, oPreviousRow As Object
Dim oThisRowData() As Variant, oPreviousRowData() As Variant
Dim oThisRowAddress As Variant
For r = nRows - 1 To 1 Step - 1
oThisRow = oCellRange.getCellRangeByPosition(0, r, nColumns - 1, r)
oThisRowData = oThisRow.getDataArray()
oPreviousRow = oCellRange.getCellRangeByPosition(0, r - 1, nColumns - 1, r - 1)
oPreviousRowData = oPreviousRow.getDataArray()
'Column A = index 0
'Column B = index 1
'Column C = index 2
'Column E = index 4
If oThisRowData(0)(0) = oPreviousRowData(0)(0) AND _
oThisRowData(0)(1) = oPreviousRowData(0)(2) AND _
oThisRowData(0)(4) = oPreviousRowData(0)(4) Then
oPreviousRowData(0)(2) = oThisRowData(0)(2)
oPreviousRow.setDataArray(oPreviousRowData)
'The following two lines delete the range and move the cells up
oThisRowAddress = oThisRow.getRangeAddress()
oSheet.removeRange(oThisRowAddress, com.sun.star.sheet.CellDeleteMode.UP)
'To delete the entire row instead of just the affected cells,
'comment out the above two lines and uncomment the following line:
'oTableRows.removeByIndex(r, 1)
End If
Next r
End Sub
I'm trying to CopyPicture cells in Column B, and name them the value in Column 1. I have code that works, except it keeps giving the pictures the wrong names. The baffling thing is that sometimes it works perfectly, and other times it does not.
I have tried to cobble together a routine based on posted examples of the CopyPicture command. I'm pasting it in below.
Yes, I'm a newbie at VBScript. Be gentle. ;-)
Sub makepic()
Dim path As String
path = "C:\BP\BP2020\JPGs\"
Dim CLen As Integer
Dim cntr As Integer
cntr = 1
Dim rgExp As Range
Dim CCntr As String
CString2 = "A1:A6"
Set rgExp2 = Range(CString2)
CString = "B1:B6"
Set rgExp = Range(CString)
For I = 1 To rgExp.Cells.Count Step 1
CCntr = rgExp2.Cells(I).Value
rgExp.Cells.Cells(I).Font.Size = 72
rgExp.Cells.Cells(I).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
rgExp.Cells.Cells(I).Font.Size = 14
''' Create an empty chart with exact size of range copied
CLen = Len(rgExp.Cells.Cells(I).Value)
CWidth = CLen * 85
With ActiveSheet.ChartObjects.Add(Left:=1600, Top:=rgExp.Top, _
Width:=CWidth, Height:=50)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
If CCntr <> "" Then
ActiveChart.Paste
Selection.Name = "pastedPic"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export (path + CCntr & ".jpg")
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
End If
cntr = cntr + 1
Next
End Sub
Again, I expect -- for example -- a picture of the contents of cell B1 to have the name of the contents of A1. I tried making the range A1:B4 (for example), but that got me 8 pictures. I finally decided to try to make 2 ranges, but that didn't work either.
I have a spreadsheet with a column of cells that each contain several paragraphs of text. I'm trying to write a macro that will grab several sentences between these text phrases "How we made our decision" and "Conclusion"
The location of this text string varies from sheet to sheet but the column is always consistent.
I've been able to find a bunch of vba scripts that allow me to find and copy 1 word at a time or simple batches of single word. I'm just not able to figure our or find something that allows me to copy an entire paragraph from within a single cell of paragraphs.
The code below just grabs the entire table. As you can see in the beginning portion I was able to get what I need however I found out that the (70) is irrelevant because the table size changes with each pull of the record.
Sub GetTheData()
Dim T As String
Dim SWs As New SHDocVw.ShellWindows
Dim IE As SHDocVw.InternetExplorer
Dim LetPr As InternetExplorer
Dim Doc As HTMLDocument
'Dim IE As Object
Dim tbls, tbl, trs, tr, tds, td, r, c
For Each IE In SWs
If IE.LocationName = "Letter Preparation Case Summary – Member Case" Then
Set LetPr = IE
'LetPr.document.getElementById
T = IE.document.getElementsByTagName("td")(70).innerText
'T = Trim(Mid(T, InStr(T, "How We Made Our Decision: ") + 0, InStr(T, "Conclusion") - (InStr(T, "How We Made Our Decision:") + 26)))
Exit For
End If
Next
Set tbls = IE.document.getElementsByTagName("table")
For r = 0 To tbls.Length - 1
Debug.Print r, tbls(r).Rows.Length
Next r
Set tbl = IE.document.getElementsByTagName("table")(9)
Set trs = tbl.getElementsByTagName("tr")
For r = 0 To trs.Length - 1
Set tds = trs(r).getElementsByTagName("td")
'if no <td> then look for <th>
If tds.Length = 0 Then Set tds = trs(r).getElementsByTagName("th")
For c = 0 To tds.Length - 1
ActiveSheet.Range("A1").Offset(r, c).Value = tds(c).innerText
Next c
Next r
End Sub
You stated that you wanted the text 'between these text phrases' so the beginning position of the found text will have to be adjusted by hte length of the searched string.
dim beginStr as string, endStr as string, beginPos as long, endPos as long
beginStr = "How We Made Our Decision:"
endStr = "Conclusion"
beginPos = instr(1, T, beginStr, vbtextcompare)
endPos = instr(beginPos, T, endStr, vbtextcompare)
if cbool(beginPos) and cbool(endPos) then
beginPos = beginPos + len(beginStr)
T = Trim(Mid(T, beginPos, endPos - beginPos))
end if
That last endPos - beginPos might have to be adjusted by subtracting 1.
I need to reformat a XML file to .CSV.
I already opened the XML in Excel and did a little formating but now I really need to write a macro to get the data into shape. I already started bu I really have issues with the loop logic.
the List has a couple thousand Articles with a variable amount of subarticles.
each subarticle as a the same amount of properties but not every article has the same properties.
https://picload.org/image/ipialic/now.jpg
https://picload.org/image/ipialip/then.jpg
My Code up till now looks like this:
Option Explicit
Dim rowCount As Long, articleCount As Long, propertyCount As Integer, name As String
Sub Sortfunction()
rowCount = 1
articleCount = 0
propertyCount = 0
Do While Sheets("Test").Cells(rowCount, 1).Value <> "end"
If Cells(rowCount, 1).Value = "Reference" Then
rowCount = rowCount + 1
Do While Cells(rowCount, 3).Value = ""
If Cells(rowCount, 3).Value = "4" Then
End If
articleCount = articleCount + 1
Loop
articleCount = articleCount + 1
End If
rowCount = rowCount + 1
Loop
Sheets("result").Cells(1, 1).Value = rowCount
Sheets("result").Cells(2, 1).Value = articleCount
End Sub
At the end of the document i wrote the "end" to have a hook to stop the loop.
Can anyone provide some help? I'm really not the best programmer :-/
I'd really appreciate any help I can get :-)
here he's a translation into algorithm and some tips on functions
update: it was more tricky than I thought... I had to rewrite the code.
The main problem is "how to decide when change column".
I choose this solution "Each product in reference must have the same amount of properties".
If it's not the case, please indicate "how you decide when you have to create a new Column" (you can explain it in plain words)
Here the code rewrited. I tried it on your exemple, it work
Public Sub test()
' Set the range to navigate in your first sheet
Dim cell As Range: Set cell = Sheets("Feuil1").Range("A1")
' set the range to navigate in your result sheet
Dim res As Range: Set res = Nothing
' pos will be used to know the position of a product
Dim lastProperties As Range, posProperties As Range
' While the cell value is not "end"
Do While cell <> "end"
' if the cell is a reference
If cell = "Reference" Then
' Set the range of res
If res Is Nothing Then
Set res = Sheets("Feuil2").Range("A1")
Else
Set res = Sheets("Feuil2").Range("A" & lastProperties.offset(2).Row)
End If
' I set Offset(2) so you will have an empty line between 2 references
' Set the text of the new reference in the result
res = cell.offset(, 1) ' The reference is the cell 1 offset the right of the cell "Reference"
' WARNING : here no writing of titles anymore. It'll be done in the "Else".
' Here you just write "new reference" and reinit var
Else
' Here we have a property
' If the property alreay exist, consider it a new product in the reference
' When we are on a new property, the column of the product if the next to the right
If GetProperties(cell.offset(, 3), res, posProperties) Then
Set lastProperties = posProperties
End If
posProperties = cell.offset(, 4)
End If
' BIG FORGET: you have to get the next cell
Set cell = cell.offset(1)
Loop
End Sub
And the function to search / create your properties
Private Function GetProperties(ByVal propValues As String, ByVal start As Range, ByRef position As Range) As Boolean
Set position = start.offset(1)
' Is the cell below the properties ? Return the row below
' Search for the first "empty row" on the line
If position = propValues Then
Do
Set position = position.offset(, 1)
Loop While Trim(position) <> ""
' Indicate it's an existing value
GetProperties = True
Exit Function
End If
' Is the range empty ?
If Trim(position) = "" Then
' Create the new properties
position = propValues
Set position = position.offset(, 1)
GetProperties = False
Exit Function
End If
' Search the properties in the row below
GetProperties = GetProperties(propValues, position, position)
End Function
It should do the work. If you have any question on understanding some part, don't hesitate
if you don't know about Offset, some reading : https://msdn.microsoft.com/en-us/library/office/ff840060.aspx