Question

我正在尝试在开放式办公室中创建一个宏，但我无法找到执行此操作。我想复制一个特定的单元格和过去在给定列上的空白销售。

基本上是这样的

Copy "B2"
If "A1" blank paste
if false
move 1 cell lower
end if

像这样的东西，我花了很多时间绘制流程图并试图让编程正确，但我只是崩溃了。我感谢您找到正确答案的任何回复或指南，谢谢。

Answer 1

有人在aoo论坛上给了我答案谢谢虽然= COUNTA（Sheet2.A1：A2）

Sub Copy2FirstBlankCell()
   Dim oDoc As Object
   Dim oSheet As Object
   Dim SourceAddress As New com.sun.star.table.CellRangeAddress
   Dim DestinationAddress As New com.sun.star.table.CellAddress
   Dim DestinationCell As Object
   Dim r As Long
   Dim c As Integer

   oDoc = ThisComponent
   oSheet = oDoc.getSheets().getByIndex(0)

   'CellrangeAddress of Sheet1.B1
   SourceAddress.Sheet = 0
   SourceAddress.StartColumn = 1
   SourceAddress.StartRow = 0
   SourceAddress.EndColumn = 1
   SourceAddress.EndRow = 0

   'CellAddress of Sheet1.A1
   r = 0
   c = 0
   DestinationAddress.Sheet = 0
   DestinationAddress.Column = c
   DestinationAddress.Row = r

   DestinationCell = oDoc.getSheets().getByIndex(DestinationAddress.Sheet).getCellByPosition(c,r)
   Do While DestinationCell.getType() <> com.sun.star.table.CellContentType.EMPTY And r < oSheet.getRows().getCount()
      r = r + 1
      DestinationAddress.Row = r
      DestinationCell = oDoc.getSheets().getByIndex(DestinationAddress.Sheet).getCellByPosition(c,r)
   Loop
   If DestinationCell.getType() = com.sun.star.table.CellContentType.EMPTY Then
      oSheet.copyRange(DestinationAddress,SourceAddress)
   Else
      Msgbox("Ran out of rows.")
   end if
End Sub

还添加了一些我可能会发现的更多有用的细节。

时间戳

Sub PutNowInCurrentCell
   Dim oDoc As Object
   Dim oSel As Object
   Dim svc as Object

   svc = createUnoService( "com.sun.star.sheet.FunctionAccess" )  'Create a service to use Calc functions

   oDoc = ThisComponent
   oSel = oDoc.getCurrentSelection()
   if oSel.supportsService("com.sun.star.sheet.SheetCell") then
      oSel.NumberFormat = getFormat("HH:MM:SS AM/PM")
      oSel.Value =  svc.callFunction("NOW",Array())
   endif

End Sub

Function getformat(f As String) As Long
   Dim oDoc As Object
   Dim NumberFormats As Object
   Dim Loc as New com.sun.star.lang.Locale
   Dim formatID As Long

   oDoc = ThisComponent

   Loc = oDoc.CharLocale

   NumberFormats = oDoc.NumberFormats

   formatId = NumberFormats.queryKey(f, Loc, False)
   If formatId = -1 Then
      formatId = NumberFormats.addNew(f, Loc)
   End If

   getformat  = formatID

End Function

<强>极小

sub Minimizer()

   dim document   as object
   dim dispatcher as object

   document   = ThisComponent.CurrentController.Frame
   dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

   dim args1(0) as new com.sun.star.beans.PropertyValue
   args1(0).Name = "ToPoint"
   args1(0).Value = "$D$10:$E$12"  ' select what is to be copied

   dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())


   dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())


   dim args3(0) as new com.sun.star.beans.PropertyValue
   args3(0).Name = "ToPoint"
   args3(0).Value = "$C$10"    ' select where i will be paste

   dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args3())
   dispatcher.executeDispatch(document, ".uno:SetInputMode", "", 0, Array())

   dispatcher.executeDispatch(document, ".uno:Paste", "", 0, Array())


   dim args5(0) as new com.sun.star.beans.PropertyValue
   args5(0).Name = "ToPoint"
   args5(0).Value = "$D$9"

   dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args5())

end sub

- あなたの若さをだれにも见下げられることのないようにしなさい

在open office Calc中创建一个If Blank paste宏

1 个答案: