- ベストアンサー
マクロを簡潔にしたいので教えてください
K Kazz（@JazzCorp）の回答
- K Kazz（@JazzCorp）
- ベストアンサー率31% (549/1751)
'Option Explicit Sub 記入() End Sub アトはEXCELを手に入れてからよ～くッ、考え直す、、、
関連するQ&A
- エクセル重複行統合マクロの意味
Tom04さんの回答で 以下のとても素晴らしいマクロがあり、 使用させていただきたいのですが、 詳細がわかりません。 少々編集して自分の書類に反映させていただきたく、 マクロの内容を教えていただけませんか？ Sub test() 'この行から Dim i, j, k, L As Long Application.ScreenUpdating = False For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column + 1 For k = Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1 If Cells(k, j) <> "" And WorksheetFunction.CountIf _ (Range(Cells(2, 1), Cells(k, 1)), Cells(k, 1)) > 1 Then L = WorksheetFunction.Match(Cells(k, 1), Columns(1), False) Cells(k, j).Cut Destination:=Cells(L, j) End If Next k Next j Next i For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If WorksheetFunction.CountA(Rows(i)) = 1 Then Rows(i).ClearContents End If Next i Application.ScreenUpdating = True End Sub 'この行まで
- ベストアンサー
- その他MS Office製品
- VBAtest
VBAおｎ以下の Sheets("ＯＰ").Select Dim atai As String atai = Cells(2, 2).Value Dim datedata(40) As String For j = 0 To 40 If Cells(j + 3, 2).Value = "" Then Else datedata(j) = Cells(j + 3, 2).Value End If Next Dim shihyou As String For i = 1 To 2 shihyou = Cells(2, i + 2).Cells.Value Sheets(shihyou).Select Dim tmp_c As Integer For r = 1 To 10 tmp_c = 0 For c = 1 To 10 If tmp_c = 0 Then If Sheets(shihyou).Cells(r, c).Value = atai Then tmp_c = c End If Else Dim vals(40) As String For k = 0 To 40 For l = 1 To r + 41 For m = 1 To tmp_c - 1 If Sheets(shihyou).Cells(l, m).Value = datedata(k) Then vals(k) = Sheets(shihyou).Cells(l, tmp_c).Value End If Next Next Next End If Next Next Sheets("ＯＰ").Select For k = 3 To 43 Cells(k, i + 2).Value = vals(k - 3) Next Next End Sub
- 締切済み
- その他（インターネット・Webサービス）
- 【Excelマクロ】もっと頭の良い書き方って無いかな？
5行空白列があったらそこで処理を終わりたいんですが、もっといい書き方はないでしょうか？ 下記が私の考えた頭の悪いやり方です。 Sub macro() Dim i As Integer For i = 1 To 1000 If Cells(i, 1) = "" Then If Cells(i + 1, 1) = "" Then If Cells(i + 2, 1) = "" Then If Cells(i + 3, 1) = "" Then If Cells(i + 4, 1) = "" Then If Cells(i + 5, 1) = "" Then MsgBox (i - 1 & "行目で終わりです") Exit For End If End If End If End If End If End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- マクロを有効にしないと表示されないようにする方法（続き）
エクセルのマクロを有効にしないと表示しないようにする方法(続き） Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim i As Integer For i = 1 To 5 Sheets(i).Visible = False Next ActiveWorkbook.Protect Password:="error" ActiveWorkbook.Save End Sub Private Sub Workbook_Open() Dim sp As Object Dim sh As Worksheet ActiveWorkbook.Unprotect Password:="error" For i = 1 To 5 Sheets(i).Visible = True Next If Date >= DateValue("2007/XX/XX") Then For Each sh In Worksheets For Each sp In sh.Shapes sp.Delete Next sp sh.Cells.Delete Next sh End If Sheets("Sheet1").Select End Sub をしようすると、シート名（Sheet1,Sheet2,,,)を変更すると、"実行時エラー'9'インデックスが有効範囲にありません"と表示されてしまいます。解決策はありますでしょうか
- 締切済み
- Visual Basic
- 簡単マクロ編集
Sheets("Sheet1").Select ←Range("A3:H8") Selection.Copy Sheets("Sheet2").Select Range("A3").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Sheet4").Select Application.CutCopyMode = False ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True 下方にこの操作を繰り返ししたいのですが Dim i As Long Worksheets("Sheet1").Select For i = 3 To 100 Step 6 If Cells(i, "A") = "" Then Exit Sub End If Cells(i, "A").Resize(6, 8).Copy Destination:=Worksheets("Sheet2").Range("A3:H8") Next i 貼付けは値で貼り付けたいと思います。 どう組み合わせればよいですか？
- ベストアンサー
- その他MS Office製品
- エクセルマクロで改ページプレビュー
お世話になります。 Sub 行挿入() For r = 3 To 50 If Len(Cells(r, 2)) = 13 Then Sheets("sheet2").Select Rows("1:55").Select Selection.Copy Rows("56:56").Select Selection.Insert Sheets("sheet1").Select End If Next End Sub というコードを書いたのですが、「End If」の前に（ｒ－１）ページ目として印刷範囲を５５行追加する、というコードを考えたのですがうまくいきません。教えていただけないでしょうか。
- ベストアンサー
- オフィス系ソフト
- エクセル２０１０でマクロが動きません
こんにちは。 マクロ超初心者です。 頑張ってエクセル２０１６でマクロ作成しましたが、エクセル２０１０で途中から動かず…。 何が悪いんでしょうか… ここから動きません…と書いたところから動きません(涙) Private Sub シート編集_Click() Application.ScreenUpdating = False Dim i Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh4 As Worksheet Set Sh1 = Worksheets("あ") Set Sh2 = Worksheets("い") Set Sh4 = Worksheets("う") Dim dayCutoff As Date dayCutoff = Application.InputBox("年月日を入力してください", "お支払期限 年月日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("D12").Value = DateSerial(Year(dayCutoff), Month(dayCutoff) + 2, 0) 'お支払期限 dayCutoff = Application.InputBox("年月日を入力してください", "請求書発行 日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("AC3").Value = Format(Date, "yyyy/mm/dd") '発行日 Sh1.Cells.Clear With Sh1 'edit .Range("A2") = "番号" .Range("B2") = "会社名" .Range("C2") = "判定" .Range("D2") = "契約番号" .Range("E2") = "拠点" .Range("F2") = "税率" .Range("G2") = "月額(税抜)" .Range("H2") = "消費税" .Range("I2") = "月額(税込)" .Range("J2") = "今回" .Range("K2") = "全回" .Range("L2") = "店番" ここから動きません………… For i = 3 To Sh2.Cells(.Rows.Count, 1).End(xlUp).Row .Cells(i, 1) = Sh2.Cells(i, 2) .Cells(i, 2) = Sh2.Cells(i, 4) .Cells(i, 4) = Sh2.Cells(i, 3) .Cells(i, 5) = Sh2.Cells(i, 4) & "(" & Sh2.Cells(i, 6) & ")" .Cells(i, 6) = Sh2.Cells(i, 9) & "%課税" .Cells(i, 7) = Sh2.Cells(i, 8) .Cells(i, 8) = Sh2.Cells(i, 10) .Cells(i, 9) = Sh2.Cells(i, 11) .Cells(i, 10) = Sh2.Cells(i, 12) .Cells(i, 11) = Sh2.Cells(i, 7) .Cells(i, 12) = Sh2.Cells(i, 2) If Sh1.Cells(i, 10) > Sh1.Cells(i, 11) Then .Cells(i, 3) = "×" Else .Cells(i, 3) = "〇" End If If Sh1.Cells(i, 3) = "×" Then .Cells(i, 2) = "" End If Next i End With '空白行を削除 Dim j As Integer, myFlag As Boolean Dim c As Range With Worksheets("edit").Range("A2").CurrentRegion For j = .Rows.Count To 2 Step -1 myFlag = False For Each c In .Cells(j, 2) If c.Value <> "" Then myFlag = True Exit For End If Next If myFlag = False Then .Rows(j).Delete End If Next End With MsgBox "データの転記が終わりました" End Sub
- 締切済み
- Visual Basic
- ｅｘｃｅｌ；マクロ；表現をもっと縮小したい
質問します。下記のようなモジュールで中に同様の数字のみが順に変わるブロック繰り返しが多数あるのですが、もっと簡略化した表現 が可能でしょうか。よろしくお願いします。 Sub usb_count() d = Range("A65536").End(xlUp).Row j = 3 For i = 2 To d Select Case Cells(i, "B") Case Sheets("sheet2").Cells(4, "A") Sheets("sheet2").Cells(4, "B").Value = Sheets("sheet2").Cells(4, "B").Value + 1 If Cells(i, "K").Value = "USB" Then Sheets("sheet2").Cells(4, "C").Value = Sheets("sheet2").Cells(4, "C").Value + 1 Else Sheets("sheet2").Cells(4, "D").Value = Sheets("sheet2").Cells(4, "D").Value + 1 ' End If ‘------------------------------------------------------------------------------------------------------------------------------------ Case Sheets("sheet2").Cells(5, "A") Sheets("sheet2").Cells(5, "B").Value = Sheets("sheet2").Cells(5, "B").Value + 1 If Cells(i, "K").Value = "USB" Then Sheets("sheet2").Cells(5, "C").Value = Sheets("sheet2").Cells(5, "C").Value + 1 Else Sheets("sheet2").Cells(5, "D").Value = Sheets("sheet2").Cells(5, "D").Value + 1 End If ‘----------------------------------------- ‘以下上記の‘-----------から‘-----------で囲まれたブロックが（ ）内の数字が６から20まで繰り返され続く が略す End Select Next i End Su
- ベストアンサー
- オフィス系ソフト
- マクロについて質問します。
このようなマクロがあるのですが、内容を変更したらうまく動きません。 Sub 請求明細自動印刷() Application.ScreenUpdating = False Dim I As Integer Dim リンクシート As String For I = 3 To Cells(Rows.Count, "A").End(xlUp).Row If Cells(I, "A") <> 0 Then リンクシート = Cells(I, "E").Hyperlinks(1).SubAddress リンクシート = Left(リンクシート, InStr(リンクシート, "!") - 1) Sheets(リンクシート).PrintOut From:=2, To:=2 End If Next I End Sub ↑の内容の ハイパーリンクセルを"E"から Dに変更したので、 ↓のように リンク先をDに変更したのですが、同じ書類が出ています （１０枚 多分 If Cells(I, "A") <> 0 Thenに該当するのが１０組なので・・・） Sub 請求明細自動印刷() Application.ScreenUpdating = False Dim I As Integer Dim リンクシート As String For I = 3 To Cells(Rows.Count, "A").End(xlUp).Row If Cells(I, "A") <> 0 Then リンクシート = Cells(I, "D").Hyperlinks(1).SubAddress リンクシート = Left(リンクシート, InStr(リンクシート, "!") - 1) Sheets(リンクシート).PrintOut From:=2, To:=2 End If Next I End Sub よくわからないのですが、どのよな形に変更するのか教えたください。 For I = 3 To Cells(Rows.Count, "A").End(xlUp).Row これは宣言文なのですか・・・・？ すみません 急いでるので 調べるより早いと思いまして お願いします。
- ベストアンサー
- オフィス系ソフト
- マクロ 色が思うように、表示できない
下記のようなコードで部品の管理をしています。条件が多くて少し複雑になっています。 とりあえずは、うまくできました。J列の結果だけが、うまくできません。 但し、J列の結果が(38はローズ )の表示がうまくいきません。(6の黄色)になってしまいます。 要するに、J列の結果が不がローズ色で、合が白色で、欠が薄いオレンジ色になればよいということなのです。 原因が分からず困ってしまって、お聞きする次第です。回答して頂けるものでしようか。 ご教授下されば幸いに存じます。よろしくお願いします。 Macro2 Macro マクロ記録日 : ' Sheets("sheet1").Select Columns("A:J").Select Selection.Copy Sheets("sheet2").Select Columns("A:J").Select ActiveSheet.Paste Application.CutCopyMode = False Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin, DataOption1:=xlSortNormal Dim i As Long, LastRow As Long LastRow = Cells(Rows.Count, "A").End(xlUp).Row Range("J2:J" & LastRow).ClearContents '← E2:Jにすると、欠に全部なります、この設定もおかしいように思いますが? Range("E2:J" & LastRow).Interior.ColorIndex = 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '文言の詳細について '部品名と詳細-------------------------------------略称 'ghyu--------------------------------------←E列 'klub---------------------------------------←F列 'llpo----------------------------------------←G列 '合計個数(合計)-------------------------←H列 合計 '数量順位---------------------------------←I列 順位 '合格・不合格(合・不)欠品(欠)-----←J列 合・不・欠 If Cells(i, "E") >= 1 And Cells(i, "E") < 20 Then Cells(i, "E").Interior.ColorIndex = 6 ' 6は 黄色 End If If Cells(i, "F") >= 1 And Cells(i, "F") < 6 Then Cells(i, "F").Interior.ColorIndex = 6 ' 6は 黄色 End If If Cells(i, "F") >= 6 And Cells(i, "F") < 10 Then Cells(i, "F").Interior.ColorIndex = 34 '34は 淡い青色 End If If Cells(i, "G") >= 1 And Cells(i, "G") < 10 Then Cells(i, "G").Interior.ColorIndex = 6 ' 6は 黄色 End If If Cells(i, "H") >= 1 And Cells(i, "H") <= 49 Then Cells(i, "H").Interior.ColorIndex = 4 ' 4は うぐいす色 End If If Cells(i, "J") >= "不" Then Cells(i, "J").Interior.ColorIndex = 38 '38は ローズ End If If Cells(i, "J") >= "合" Then Cells(i, "J").Interior.ColorIndex = 2 ' 2は 白色 End If For j = 5 To 9 'D-F If Cells(i, j).Value = 0 Then Cells(i, j).Interior.ColorIndex = 3 '3は 赤色 ElseIf Cells(i, j).Value = "欠" Then Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色 End If Next j For k = 5 To 9 'G-I If Cells(i, j).Value = "欠" Then Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色 End If Next k Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
お礼
ありがとうございます。excel VBAに慣れていませんので、改めて勉強してみます。