- ベストアンサー
LibreOfficeでマクロを動かしたい。
エクセルからLibreOfficeに乗り換えたいのですが、エクセルで起動しているVBAが動きません。 コードは Rem Attribute VBA_ModuleType=VBAModule Option VBASupport 1 Sub Sample4() Dim Ws As Worksheet For Each Ws In Worksheets Ws.Activate If Not Ws.Name Like "貼り付け" Then Range("A3:I3").Select Selection.Copy Dim Last_Row As Long Last_Row = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row Cells(Last_Row + 1, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If Next Ws ActiveWorkbook.Save '開いているシートを上書き保存 End Sub このコードで、 If Not Ws.Name Like "貼り付け" Then が「BASICランタイムエラー.'13'データの種類が一致していません。」 と表示されます。 エクセルでは問題なく起動していたのでどこを直せばいいのかわからず、困っています。 このVBAをLibreOfficeで動かすにはどこを修正すればいいのでしょうか。
- okozyo
- お礼率72% (98/135)
- オフィス系ソフト
- 回答数4
- ありがとう数6
- みんなの回答 （4）
- 専門家の回答
質問者が選んだベストアンサー
Like演算子はLibreOffice CalcのVBAではサポートされていないようです。 If Not Ws.Name Like “貼り付け” Then の代替方法: Like演算子の代わりに、<>演算子を使用するのは ？ If Ws.Name <> "貼り付け" Then
その他の回答 (3)
- heisukewada
- ベストアンサー率57% (69/120)
意図が違っているかもしれませんが LibreOffice Calc マクロ Basic を、ChatGPTと相談しながら作りました。 Sub CopyDataToLastRow Dim oSheets As Object Dim oSheet As Object Dim oSourceRange As Object Dim oDestRange As Object Dim lastRow As Long ' 全てのシートを取得 oSheets = ThisComponent.getSheets() ' 各シートに対してループ For i = 0 To oSheets.getCount() - 1 oSheet = oSheets.getByIndex(i) ' シート名を取得 Dim sheetName As String sheetName = oSheet.getName() ' シート名が "貼り付け" でない場合の処理 If sheetName <> "貼り付け" Then ' ソース範囲を指定 oSourceRange = oSheet.getCellRangeByName("A3:I3") ' 最終行を見つける lastRow = getLastRowInColumn(oSheet, "A") + 1 ' 宛先範囲を指定 oDestRange = oSheet.getCellRangeByPosition(0, lastRow, 8, lastRow) ' ソース範囲の値を直接宛先範囲に設定 oDestRange.setDataArray(oSourceRange.getDataArray()) End If Next i End Sub
お礼
ご回答ありがとうございます。 これは、これで助かります。 ChatGPT、使ったけど、望む答えやコードは全くかえってこなくて、ググったときにみたサイトの情報しか返ってこなかった。しかも、エクセル用のVBA・
- NuboChan
- ベストアンサー率47% (745/1583)
LibreOfficeはVBAを完全にサポートしていないため、一部のコードは修正が必要です。 ワイルドカード文字（`*`）が追加では ？ If Not Ws.Name Like "*貼り付け*" Then
補足
ワイルドカードを入れてみましたがダメでした。 If Not Ws.Name Like "貼り付け" Then 部分を削除すれば、マクロ自体は正常に動いているので、構文のどこかに間違いがあるか、LibreOfficeでIf Not かLikeが認識しないということはないのでしょうか。
関連するQ&A
- マクロ 値貼付 oguno
●日付表示をyy-mm-dd(07-03-04)と、したかったのですが構文1では「3/4/2007」の表示になってしまいました。 ●構文2のように修正しましたら、希望の日付表示「07-03-04」になりました。 ●修正箇所 構文1の「Value」を「Copy」と修正し、 「Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False」を追加しました。 ーーーーーーーーーーーーーーーーーーーーーーーー ●お願い 希望の日付表示にはなりましたが、記述の仕方が、これで正しいのかどうか、初心者のため自信がありません。 正しく記述しているのかどうか、ご検証をお願いいたします。 なお、構文１もこのサイトでご指導いただいたものです。 ーーーーーーーーーーーーーーーーーーーーーーーー ●構文１ '未転記のデータがあればデータコピー If WS1Mon > WS2Mon Then If WS2.Cells(StartRow, 2).Value <> "" Then CopyToRow = WS2LastRow + 1 Else CopyToRow = StartRow End If WS2.Cells(CopyToRow, 2).Resize(WS1Mon - WS2Mon, 7).Value = _ WS1.Cells(StartRow + WS2Mon, 2).Resize(WS1Mon - WS2Mon, 7).Value WS2.Cells(CopyToRow, 2).Resize(WS1Mon - WS2Mon, 7).Select Else Selection.Select End If Application.CutCopyMode = False ●構文２ '未転記のデータがあればデータコピー If WS1Mon > WS2Mon Then If WS2.Cells(StartRow, 2).Value <> "" Then CopyToRow = WS2LastRow + 1 Else CopyToRow = StartRow End If WS2.Cells(CopyToRow, 2).Resize(WS1Mon - WS2Mon, 7).Value = _ WS1.Cells(StartRow + WS2Mon, 2).Resize(WS1Mon - WS2Mon, 7).Copy WS2.Cells(CopyToRow, 2).Resize(WS1Mon - WS2Mon, 7).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Else Selection.Select End If Application.CutCopyMode = False
- ベストアンサー
- オフィス系ソフト
- Excel 2007 マクロのIF構文について
Excel 2007 マクロのIF構文について Sheet1からSheet2にIF構文を使用して、 必要な情報を転記するマクロです。 下記マクロで実現できているのですが、IF構文が多く もっと効率的なマクロがあるのではないかと考えています。 IF構文が2つありますが、1つにまとめるマクロがありましたら お教えください。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '「Sheet1」シートを更新 Worksheets("Sheet1").Range("A1").ListObject.QueryTable.Refresh BackgroundQuery:=False '「Sheet1」シートから「Sheet2」シートに転記 For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, 13).End(xlUp).Row '「Sheet1」シートのL列から「Sheet2」シートのS列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "S") = ws1.Cells(i, "L") End If '「Sheet1」シートのG列から「Sheet2」シートのQ列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "Q") = ws1.Cells(i, "G") End If Next j Next i End Sub
- ベストアンサー
- その他MS Office製品
- VBA 空白表示させたい
教えて頂いたＶＢＡなのですが Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents If Selection(Selection.Count).Row <> 2 Then Exit Sub Counter = 0 For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j If INP <> "" Then Counter = Counter + 1 wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub ---------------------------------------------------------------------- ｇ ｈ ｉ ｊ パセリ クレソン メキャベツの葉 ごぼう １ １ １ １ １ 1行目 パセリ,クレソン,メキャベツの葉 2行目 3行目 パセリ,メキャベツの葉 と、2行目は詰めずに空白表示したいです。 どこをどうすればできますか？
- ベストアンサー
- Excel（エクセル）
- 複数行コピー、貼り付け実行時エラー1004
ユーザー側が任意の場所を選択コピー し(2行毎) また 任意の位置に貼り付ける動作ですが 1回目のコピー、貼り付けは正常動作しますが 再度 コピー(任意の場所),貼り付け時に1004実行エラーが発生します。 下記はコードです。 どうかご教授お願いいたします。 Dim StartRow As Long, LastRow As Long, SRC As Long Sub コピー() If ActiveCell.Row < 76 Then Exit Sub StartRow = ActiveCell.Row: SRC = Selection.Rows.Count If (ActiveCell.Row Mod 2) = 0 Then StartRow = ActiveCell.Row If (Selection.Rows.Count Mod 2) = 0 Then LastRow = StartRow + Selection.Rows.Count - 1 Else LastRow = StartRow + Selection.Rows.Count End If Else StartRow = ActiveCell.Row - 1 If (Selection.Rows.Count Mod 2) = 0 Then LastRow = StartRow + Selection.Rows.Count + 1 Else LastRow = StartRow + Selection.Rows.Count End If End If ActiveSheet.Range(ActiveSheet.Cells(StartRow, 1), ActiveSheet.Cells(LastRow, 19)).Copy End Sub Sub 貼付け() If ActiveCell.Row >= 76 Or Application.ClipboardFormats(1) <> -1 Then ActiveSheet.Unprotect If (ActiveCell.Row Mod 2) = 0 Then StartRow = ActiveCell.Row Else StartRow = ActiveCell.Row - 1 End If ActiveSheet.Paste Destination:=Cells(StartRow, 1): Application.CutCopyMode = False ActiveSheet.Protect End If End Sub
- 締切済み
- Visual Basic
- ファイルオープン時のマクロが一部実行されない
いつも回答して頂き、ありがとうございます。感謝感謝です。 ファイルオープン時にApplication.Runで３つのマクロを実行させているのですが、最後のマクロだけ実行されません。どうしてでしょうか？もしかして、前の２つで『一覧シート』を除外するマクロを実行しているからでしょうか？御指導の程宜しくお願いいたします。 1番目に実行するマクロ Sub 特定のシート以外の最終履歴と次回予定日を算出する() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Integer c = 3 Do While ws.Cells(2, c).Value <> "" With ws.Cells(6, c) .FormulaR1C1 = "=MAX(R8C:R10000C)" If .Value = 0 Then .Value = "履歴無し" ws.Cells(7, c).ClearContents Else .Value = .Value ws.Cells(7, c) = DateAdd("d", ws.Cells(5, c), DateAdd("m", ws.Cells(4, c), DateAdd("yyyy", ws.Cells(3, c), ws.Cells(6, c)))) End If End With c = c + 1 Loop End If End If Next End Sub ２番目に実行するマクロ Sub 期限の未達と到達を色で分ける() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Long Dim res As Variant For c = 3 To ws.Cells(7, Columns.Count).End(xlToLeft).Column If IsDate(ws.Cells(7, c)) Then If ws.Cells(7, c) > Date Then res = 8 Else res = 3 End If Else res = xlNone End If ws.Cells(7, c).Interior.ColorIndex = res Next c End If End If Next End Sub ３番目に実行するマクロ Sub 各シートの情報を一覧へ転記する() Dim d As Integer Dim retu As Integer d = 3 Do While Cells(d, 2).Value <> "" With Worksheets(Worksheets("一覧").Cells(d, 2).Value) .Activate retu = .Range("IV7").End(xlToLeft).Column .Range(Cells(7, 3), Cells(7, retu)).Copy End With With Worksheets("一覧") .Activate Cells(d, 3).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End With d = d + 1 Loop End Sub
- ベストアンサー
- オフィス系ソフト
- 抜き出しマクロ(3)
以下のプログラムは10行ごとにデータを抜き出すプログラムです。 これに追加して、普段は10行に1個データを抜き出し、前回の結果より絶対値が10増減があったとき、 相対値が10%の増減があった時にもデータを抜き出すようにするにはどうすればいいですか？ 例えば以下の通り time result 1 1 2 1 3 1 4 1 5 1 6 1 7 1 8 1 9 1 10 1 11 100 12 500 13 1000 14 1000 15 1000 16 1000 17 1000 18 1000 19 1000 20 1000 21 1000 ・ ・ ・ ・ ・ ・ ↓ time result 1 1 10 1 11 100 12 500 13 1000 20 1000 ・ ・ ・ ・ ・ ・ ここからプログラム(10行ごとに抜き出す) ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ Sub nukitori() Dim X As Worksheet Dim i As Long Dim ii As Long Dim col As Integer Dim Nukitori_Step As Long Nukitori_Step = 10 i = 2 ii = 2 '●●●見出し行が１行目なので２で始める Set X = ActiveSheet '●シートShordataがあったら削除 On Error Resume Next Application.DisplayAlerts = False Worksheets("shortdata").Delete Application.DisplayAlerts = True On Error GoTo 0 Worksheets.Add.Name = "shortdata" '●先ず、見出しをコピー Worksheets("shortdata").Rows(1).Value = X.Rows(1).Value While X.Cells(i, 1) <> "" And i < 65535 For col = 1 To 255 Worksheets("shortdata").Cells(ii, col).Value = X.Cells(i, col).Value Next If i = 2 Then i = 1 i = i + Nukitori_Step ii = ii + 1 Wend End Sub ここからプログラム(10行ごとに抜き出す+増減があった場合も抜き出す) ただし以下の箇所でエラーが起こる If i > 3 And Abs(Cells(i, 1) - Cells(i - 1)) >= 10 Then 中断モードでコードを実行することができませんと。 ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ Sub 抽出() Dim i As Long Dim j As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim Lastline As Long Dim SelFlg As Boolean '抽出データかどうかの Set ws1 = Worksheets("OriginDT") '元データ Set ws2 = Worksheets("SelectDT") '抽出データ Lastline = ws1.Cells(Rows.Count, 1).End(xlUp).Row '最終行番号を取得 ws2.Cells(1, 1) = ws1.Cells(1, 1) '見出し部分のコピー ws2.Cells(1, 2) = ws1.Cells(1, 2) j = 1 For i = 2 To Lastline SelFlg = False '10で割ったあまりが1（つまり10行おき)または最初のデータのとき If i Mod 10 = 1 Or i = 2 Then ' SelFlg = True '抽出対象にする End If '2行目以降で一つ上の行との差が10以上のとき If i > 3 And Abs(Cells(i, 1) - Cells(i - 1)) >= 10 Then SelFlg = True '抽出対象にする End If If SelFlg = True Then '抽出対象だったらコピー j = j + 1 ws2.Cells(j, 1) = ws1.Cells(i, 1) ws2.Cells(j, 2) = ws1.Cells(i, 2) End If Next End Sub
- 締切済み
- Visual Basic
- VBA どこでもセル選択
教えて頂いたＶＢＡなのですがもう一つ Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j Counter = Counter + 1 If INP <> "" Then wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub -------------------------------------------------------------- For i = 3 のところを3としないでどのセル（行）にも対応させたいのですが どうすればいいでしょうか？
- ベストアンサー
- Excel（エクセル）
- 完全一致したら複数のセルを順に代入するマクロは？
エクセルのSheet1のA列にある文字列と、Sheet2にあるA列にある文字列と完全一致したら、前者のセルの右右右隣セル（一致したセルから数えて４番目のセル）から３番目までのセルに、後者のセルの右隣セル（一致したセルから数えて２番目のセル）から３番目までの文字列を順に代入するマクロをお教えください。つまり代入開始セルをSheet1のD列にしたいのです。（実は任意の列からにしたのですが…）。単純にvlookup関数を使えばいいのですが、ＶＢＡで行いたいのです。 一致したセルの右隣のセルから順に代入するマクロは以下で解決済みです。以下のマクロを編集して実行したいのですが、どこをいじったらよいかわかりません。 なお、代入したいセルを右の任意のセルまで引き延ばしたい場合、以下のコード任意Loop Until Coln1 = 4の右辺の数字を変更すればよいことまではわかっています。どうぞ、よろしくお願い申し上げます。 ---------------- Sub 試験() Dim Row1 As Integer Dim Coln1 As Integer Dim Row2 As Integer Dim Coln2 As Integer Set WS1 = Worksheets("Sheet1") Set WS2 = Worksheets("Sheet2") Coln1 = 1 Coln2 = 1 For Row1 = 1 To WS1.Cells(Rows.Count, 1).End(xlUp).Row For Row2 = 1 To WS2.Cells(Rows.Count, 1).End(xlUp).Row If WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1) Then Do Coln1 = Coln1 + 1 Coln2 = Coln2 + 1 WS1.Cells(Row1, Coln1) = WS2.Cells(Row2, Coln2) Loop Until Coln1 = 4 Coln1 = 1 Coln2 = 1 End If Next Row2 Next Row1 End Sub
- ベストアンサー
- オフィス系ソフト
- 複数のエクセルシートをまとめるマクロ
下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub
- ベストアンサー
- Excel（エクセル）
- 置換のマクロ
すみません、基礎的なことかもしれませんが、 調べてもわかりませんでした… 下記マクロで、今はwS1のA列に置換したい文字があった場合 置換をしてくれますが、 A列だけではなく、wS1のシート全体を指定する為にはどのように書き換えればいいでしょうか…？ Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A") の wS1.Cells(i, "A") を Aではなく、シート全体の指定に変えたいのです。。 Sub 置換() Dim i As Long, k As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = ActiveSheet Set wS2 = Worksheets("置換") Application.ScreenUpdating = False For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row For k = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If InStr(wS1.Cells(i, "A"), wS2.Cells(k, "A")) > 0 Then wS1.Cells(i, "A") = Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A"), wS2.Cells(k, "B")) End If Next k Next i Application.ScreenUpdating = True End Sub 過去の質問↓の回答にあったマクロから、少し変えて使わせていただいています。 http://okwave.jp/qa/q8293972.html
- ベストアンサー
- Excel（エクセル）
お礼