Sub NameFilt()
Dim Myrange As Range
Dim i As Integer
Set Myrange = Application.InputBox(prompt:="Select IPT Names", Title:="NAME FILTRATION", Type:="8")
For Each Cell In Myrange
If Excel.WorksheetFunction.Proper(Myrange.Value) Then
Cells(i, 8).Value = Excel.WorksheetFunction.Proper(Myrange.Value)
i = i + 1
Else
Myrange.Interior.Color.vbBlue
End If
Next Cell
End Sub
Related
This Macro is used to cut, insert and delete a cell range section of a workbook.
The problem I was trying to solve and gave up with the lack of response in another thread is why copying multiple non-adjacent rows to the MS clipboard often loses their row line-breaks when pasting.
E.g. Since trying to paste 3 non-adjacent rows into row 10, 11 and 12, often puts all 3 rows into row 10 with one row in fields A10-P10, the next row in Q10-AF10 and the last row into AG10-AV10...
I edited the Macro below to fix this mistake when this happens.
So, for example, I can now highlight row 10 and run the macro to cut/insert the fields Q10-AF10 to A11-P11 and delete/shift left the blank fields now in Q10-AF10.
I'm hoping for help to loop this process until there's no data outside Column A-P. In this case, no data outside cell P10.
Sub FixAllOnLine1OneRowAtATimeInsertToNextRow()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = ActiveSheet
Set pasteSheet = ActiveSheet
copySheet.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Copy
Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Offset(1).Select
pasteSheet.Cells(ActiveCell.Row, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
Columns("Q:AF").Select
Selection.Delete Shift:=xlToLeft
End Sub
Ok, I made some headway. I just have one super easy issue and then I need to loop it.
The first issue is that it cuts Column Q:AF correct of the row I've highlighted and shifts the entire Column Q:AF to the left, but it INSERTS the cut cells into the fixed range, A2:P2. I want to INSERT the cut cells down ONE row from my selection. I KNOW this is a couple characters in the Offset, I just can't get it.
Then, once it's working properly...say I highlight row 10, it cuts Q10:AF10 and instead INSERTS the cells into A11:P11 and shifts "Q:AF" to the left, then I need to figure out how to get it to loop until there's no more data to right of Column P. When this problem occurs pasting multiple rows from the clipboard all into the first row losing the row line-breaks, it's always quite a few rows.
Any ideas?
Thanks so much!
Mark
Sub FixAllOnLine1OneRowAtATimeInsertToNextRow()
Dim ws As Worksheet
Dim lNextRow As Long
Application.ScreenUpdating = False
Set ws = ActiveSheet
ws.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Copy 'Copy the row of the selected cell from Q:AF
ws.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Offset(1).Select 'Select the cells you have just copied. Not needed
ws.Cells(ActiveCell.Row, 1).End(xlUp).Offset(1, 0).Insert xlShiftDown ' Paste the copied values in to column "A" on next row?
'lNextRow = ws.Range("A" & Rows.count).End(xlUp).Row + 1 'Get Next Row number
'Range("A" & lNextRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("Q:AF").Delete Shift:=xlToLeft
'Columns("Q:AF").Select
'Selection.Delete Shift:=xlToLeft
Application.ScreenUpdating = True
ActiveCell.Offset(RowOffset:=-1, columnOffset:=0).Activate 'Added to move active cell up one row to run it again for multiple groups to apply fix.
End Sub
Here's a solution in another direction just in case someone from the engines needs it...
Sub ReduceNoOfColumns()
Dim iRow As Integer 'Row to be manipulated
Dim iRowToPasteTo 'Row number to paste the copied cells
Dim iCurCol As Integer 'Current Column number of first cell with a value to cut
Dim NoOfCols As Integer 'integer to hold max number of columns
Dim sAddress As String
iRow = ActiveCell.Row
iRowToPasteTo = iRow + 1
NoOfCols = 16 'Set this number to the total number of columns you wish to have (in your case 16)
iCurCol = NoOfCols + 1
Do Until Cells(iRow, iCurCol).Value = "" 'Keep looping until we get to an empty column
sAddress = ColNoToLetter(iCurCol) & iRow & ":" & ColNoToLetter(iCurCol + NoOfCols - 1) & iRow
Rows(iRowToPasteTo & ":" & iRowToPasteTo).Insert Shift:=xlDown
Range(sAddress).Copy
Range("A" & iRowToPasteTo).PasteSpecial xlPasteAll
Range(sAddress).Clear
iCurCol = iCurCol + NoOfCols
iRowToPasteTo = iRowToPasteTo + 1
Loop
End Sub
Function ColNoToLetter(iCol As Integer) As String
Dim vArr
vArr = Split(Cells(1, iCol).Address(True, False), "$")
ColNoToLetter = vArr(0)
End Function
Have not been able to find anything that fits my needs.
I have two columns of values (L and U). Column L contains a file names that includes a date in MM-DD-YYYY format (example yadayadayada thru (03-15-2015).pdf) column U contains a date. What I need to do is have a macro compare the date within the file name to the date in the column U. Other dates may appear within the text in column L but the date I need to compare against is always after "thru" and in parentheses followed by the file extension. If they do not match, I need the value in column U highlighted and replaced with the text "FAIL". I'm going to continue searching but any help is greatly appreciated. Thanks!
Does it have to be VBA? This can be accomplished with Conditional Formatting.
Apply this conditional format formula to column U:
=AND(U1<>"",L1<>"",U1<>--TRIM(MID(SUBSTITUTE(TRIM(RIGHT(SUBSTITUTE(L1," ",REPT(" ",255)),255)),")",REPT(" ",255)),2,255)))
And set the number format to Custom "FAIL" with yellow (or the highlight color of your choice) fill.
EDIT
If it has to be VBA, then this should work for you:
Sub tgr()
Const HeaderRow As Long = 1 'Change to your actual header row
Dim ws As Worksheet
Dim rngFail As Range
Dim rngFiles As Range
Dim FileCell As Range
Dim dDate As Double
Set ws = ActiveWorkbook.ActiveSheet
Set rngFiles = ws.Range("L" & HeaderRow + 1, ws.Cells(Rows.Count, "L").End(xlUp))
If rngFiles.Row < HeaderRow + 1 Then Exit Sub 'No data
For Each FileCell In rngFiles.Cells
If Len(Trim(FileCell.Text)) > 0 Then
dDate = 0
On Error Resume Next
dDate = CDbl(CDate(Trim(Mid(Replace(Trim(Right(Replace(FileCell.Text, " ", String(255, " ")), 255)), ")", String(255, " ")), 2, 255))))
On Error GoTo 0
If dDate <> ws.Cells(FileCell.Row, "U").Value2 Then
Select Case (rngFail Is Nothing)
Case True: Set rngFail = ws.Cells(FileCell.Row, "U")
Case Else: Set rngFail = Union(rngFail, ws.Cells(FileCell.Row, "U"))
End Select
End If
End If
Next FileCell
If Not rngFail Is Nothing Then
rngFail.Value = "FAIL"
rngFail.Interior.ColorIndex = 6
End If
End Sub
I've been searching a lot but could find little to no info about LibreOffice Basic
I'm a bit used to programming macros in excel but this time a need to do a loop until i reach the first empty column and it needs to be in libreoffice.
In excel i would do something like this:
Dim i As integer
i = 0
Range("A1").Select
While cell.Offset(0, i).Value <> Null
i = i + 1
Wend
MsgBox ("First empty column is " & Chr(i + 64))
But in libreoffice i have no idea.
Can anyone help me.
Thanks,
Bruno
I managed to find the answer this way:
dim cell as object
dim i as integer
i = 0
cell = Sheet.getCellByPosition(i,0)
while Cell.Type <> com.sun.star.table.CellContentType.EMPTY
i = i+1
cell = Sheet.getCellByPosition(i,0)
wend
When the loop ends I get the variable i which corresponds to the column number. I can then convert it to the letter the same way as in excel (chr functions)
rem I had a similar problem to solve.
rem Update for libreoffice 7.
rem Replaced "sheet" with "ThisComponent.Sheets(0)".
rem Thanks.
sub main
dim cell as object
dim i as integer
i = 0
rem "sheet" alone does not run
cell = ThisComponent.Sheets(0).getCellByPosition(i,0)
while Cell.Type <> com.sun.star.table.CellContentType.EMPTY
i = i+1
cell = ThisComponent.Sheets(0).getCellByPosition(i,0)
wend
MsgBox( i )
end sub
I would like to replace the text below with only http://www.someurl.com. I have Word mac 2011. To clarify, I do not actually want to return from the field code to the actual hyperlink (blue), I only want the address as text in the document.
{ HYPERLINK "http://www.someurl.com" }
Something like this (but notice it won't deal with nested fields), and unless you change Word preferences, Word will re-insert the links when you start editing the results:
Sub replaceHLs()
Dim hl As Word.Hyperlink
Dim i As Integer
Dim r As Word.Range
Dim strLinkText As String
For i = ActiveDocument.Hyperlinks.Count To 1 Step -1
With ActiveDocument.Hyperlinks(i)
Set r = .Range
strLinkText = .Address
' optional, should be OK for HTML links
If .SubAddress <> "" Then
strLinkText = strLinkText & "#" & .SubAddress
End If
r.Text = strLinkText
r.Font.Color = wdColorBlue
r.Font.Underline = wdUnderlineSingle
Set r = Nothing
End With
Next
End Sub
The autofilter is sorting data vertically, but I want to filter rows horizontally.
Lets say that I have the following table:
1 2 2 1 2
B A E F F
B D E F F
C D E F F
What I can do is to set an autofilter and filter only the rows containing "B" in the first column. What I would like to do is to filter only the rows that contain "2" (in this case the rows are second, third and the last in this case).
I have found some information regarding this matter. All of the answers I found are containing some macros to get the job done, but they were written for MS Excel, and are not compatible with OpenOffice
For example, this macros should get the rows filtered, but is not working in OpenOffice Calc:
Option Explicit
Sub horizontal_filter()
'Erik Van Geit
'060910
Dim LC As Integer 'Last Column
Dim R As Long
Dim i As Integer
Dim FilterValue As String
Const FilterColumn = 1 '1 is most logical value but you may change this
R = ActiveCell.Row
LC = Cells(R, Columns.Count).End(xlToLeft).Column
FilterValue = Cells(R, FilterColumn)
Application.ScreenUpdating = False
'to filter starting after FilterColumn
For i = FilterColumn + 1 To LC
'to filter all columns even before the filtercolumn
'For i = 1 To LC
If i <> FilterColumn Then
Columns(i).Hidden = Cells(R, i) <> FilterValue
End If
Next i
Application.ScreenUpdating = True
End Sub
Any help is greatly appreciated!
You can't, under the assumption of reasonable expense. It's much easier just to transform your data so that rows get columns and vice versa. So, i would strongly recommend transforming the data using Paste Special together with the Transpose option. You could even do this dynamically by using the TRANSPOSE() function.
EDIT:
Now i got it - you want to hide columns based on a certain value. This is possible using a macro in fact, so my first answer was incorrect - sorry for that! There are some macros around that will do this for you. You can combine such a solution with an auto filter. Here's a solution by king_026 from the OpenOffice.org forums (slightly adapted to table structure - see below):
REM ***** BASIC *****
sub hide
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
rem get the current column
nCol = ThisComponent.CurrentSelection.CellAddress.Column
rem set the properties for moving right
dim args2(1) as new com.sun.star.beans.PropertyValue
args2(0).Name = "By"
args2(0).Value = 1
args2(1).Name = "Sel"
args2(1).Value = false
rem make thecurrent column counter
dim cCol as integer
CCol = 0
rem goto the first column
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "ToPoint"
args1(0).Value = "$A$2"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())
rem loop until you get back to the selected cell
Do Until cCol > nCol
rem hide if the cell value is 1
if ThisComponent.CurrentSelection.string <> "" and ThisComponent.CurrentSelection.value = 1 then
rem ----------------------------------------------------------------------
dispatcher.executeDispatch(document, ".uno:HideColumn", "", 0, Array())
End if
rem goto the right nad increment the column counter
dispatcher.executeDispatch(document, ".uno:GoRight", "", 0, args2())
cCol = cCol + 1
Loop
End sub
So, the following table:
will look like this after Autofilter on Col1 and after the macro did his work: