• ベストアンサー

ExcelのVBAで一部困っています。

現在下記のようなプログラム(一部)を使っています。 数式をコピーしているのですが、これを左側のセルが空白になったらコピーをやめるか、数式記入をやめる方法に変えたいのですが、どなたか、ご教授ください。 後で余計にコピーしたセルを消す作業を低減したいと思っています。 宜しくお願いします。 Range("E1").Select ActiveCell.FormulaR1C1 = "専用コード" Range("E2").Select ActiveCell.FormulaR1C1 = _ "=IF(RC[-1]=""ホンテン "",""ラ001"",IF(RC[-1]=""エーテン "",""ラ005"",IF(RC[-1]=""ビーテン "",""ラ007"",IF(RC[-1]=""シーテン "",""ラ008"",IF(RC[-1]=""ディーテン "",""ラ009"",IF(RC[-1]=""イーテン "",""ラ015"",IF(RC[-1]=""エフテン "",""ラ011"",IF(RC[-1]=""ジーテン "",""ラ014"",""""))))))))" Range("E2").Select Selection.Copy Range("e3:e1500").Select

質問者が選んだベストアンサー

  • ベストアンサー
  • fujillin
  • ベストアンサー率61% (1594/2576)
回答No.2

ご質問のコードが途中で切れてしまっていますが、そのあとにE2の内容をpasteしているものと推測して… 普通にループでやるなら  For Each c In Range("E2:E" & Cells(Rows.Count, 4).End(xlUp).Row   c.FormulaR1C1 = Range("E2").FormulaR1C1  Next c エクセルのオートフィルでやるなら  Range("E2").AutoFill Destination:=Range("E2:E" & Cells(Rows.Count, 4).End(xlUp).Row) みたいな感じ。 ちなみに「D列が空白だったら」ではなく「D列の最終行まで」という形で記しています。 「D列が空白だったら」をそのまま記述するなら、  Do While~ や Do Untill~ などになろうかと思います。

kenchiki
質問者

お礼

早速にありがとうござました。 試してみたところ、うまくいきました。 助かりました。 本当にありがとうございました。

その他の回答 (2)

noname#187541
noname#187541
回答No.3

こんにちは。 数式をコピー(正確にはセルすべてですね)はしていますが、貼り付け(ペースト)の記述がないですね。 E3:E1500を範囲選択してコードが終わっていますが、この範囲に貼り付けると言うことでしょうか。 この範囲の左隣のセルが空白になったらコピーをやめる、逆に言うと空白になるまでが貼り付ける範囲と言うことですね。 それから、SelectしてActiveCellにしてから処理しているようですが、このような処理は無駄です。Selectしないで直接処理しましょう。 と言うことで、こんな感じでしょうか。 Dim myRow As Long Range("E1").FormulaR1C1 = "専用コード" Range("E2").FormulaR1C1 = _ "=IF(RC[-1]=""ホンテン "",""ラ001"",IF(RC[-1]=""エーテン "",""ラ005"",IF(RC[-1]=""ビーテン "",""ラ007"",IF(RC[-1]=""シーテン "",""ラ008"",IF(RC[-1]=""ディーテン "",""ラ009"",IF(RC[-1]=""イーテン "",""ラ015"",IF(RC[-1]=""エフテン "",""ラ011"",IF(RC[-1]=""ジーテン "",""ラ014"",""""))))))))" myRow = Range("D3").End(xlDown).Row Range("E2").Copy Destination:=Range("E3:E" & myRow) Range("E" & myRow + 1 & ":E1500").ClearContents

kenchiki
質問者

お礼

ご回答ありがとうございます。 >それから、SelectしてActiveCellにしてから処理しているようですが、このような処理は無駄です。Selectしないで直接処理しましょう。 ご指摘、ごもっともです。 ありがとうございました。 大変参考になりました。 本当にありがとうございました。

  • cj_mover
  • ベストアンサー率76% (292/381)
回答No.1

Sub test() Cells.CurrentRegion.Columns(5).Formula _  = "=INDEX(" _  & "{"""";""ラ001"";""ラ005"";""ラ007"";""ラ008"";""ラ009"";""ラ015"";""ラ011"";""ラ014""}" _  & ",SUMPRODUCT(" _  & "COUNTIF(D1," _  & "{""ホンテン "";""エーテン "";""ビーテン "";""シーテン "";""ディーテン "";""イーテン "";""エフテン "";""ジーテン ""}" _  & ")*ROW($1:$8))+1)" End Sub 1) CurrentRegion については、ヘルプで確認してください。   こんな時に使う為のものです。   本来、テーブル形式になっているExcelシートは   「表は必ず、空白行と空白列に囲まれている。」   「表の中には、空白行と空白列を作らない。」   というルールで作られるべきものなので、   適合していれば扱いが楽になる好例です。 2) 例示された数式で、"ホンテン "など、後ろに半角スペースが付いていますので、   そのまま反映させました。 3) VBAに関するご質問ですが、例示された数式は、Excel2007以降のバージョンでしか使えないので、   汎用式になおしました。   例示された式の右辺エクセル数式の RC[-1]= を、D1= に置換すれば、原型の数式でもいける筈です。 4) Excel数式レベルの話ですが、数式の中にリストを組み込むのは、あまり感心しません。   セル範囲に作ったリスト(テーブル)を、セル範囲として参照する方が、   数式も組み易く、より高度に応用でき、ファイルも軽く済みます。 5) 関連の質問も拝見しました。   私ならどうするか、真面目に考えました。   お求めになっているものが、「何を持って良しとする」のかが、   把握できていないので、期待に添えなかったらスミマセン。 6) 私はExcel数式あまり得意じゃありません。

kenchiki
質問者

お礼

早速にありがとうございました。 大変参考になりましたよ。 >6) 私はExcel数式あまり得意じゃありません。 にも関わらず、的確なアドバイスありがとうございました。

関連するQ&A

  • 文字列を連続で置き換え・・・・?

    マクロを記録したんですが手直しして繰り返しと空白のセル内が見つかった場合 繰り返しを終わらせワードパッドにコピーして保存終了させたいんですがわかりません? 誰か教えてください。 ' ' Macro2 Macro ' マクロ記録日 : 2012/4/21 ユーザー名 : cocoro ' ' Range("E:E").Select ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],""#"",RC[-4])" Range("F1").Select ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],""$"",RC[-4])" Range("G1").Select ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],""&"",RC[-4])" Range("E2").Select ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],""#"",RC[-4])" Range("F2").Select ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],""$"",RC[-4])" Range("G2").Select ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],""&"",RC[-4])" Columns("G:G").Select Selection.Copy Columns("H:H").Select Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Columns("H:H").Select ActiveWindow.SmallScroll Down:=-6 Application.CutCopyMode = False Selection.Copy End Sub

  • エクセルVBAの保存

    毎月異なった新しいエクセルファイルに同じような加工を施すため、VBAを書きました。対象はActivesheetとしています。 で、質問は、この新しいエクセルファイルの標準モジュールにいちいちこのVBAをコピーペーストせずに実行する方法です。 きっと何かあるとは思うのですが・・・・。 VBAは次のような簡単なものです。 Sub 加工1() Dim e As Integer, s As String, n As String e = Range("A4").End(xlDown).Row s = Replace(Mid(Range("A2"), 8, 5), "年", "") & "-" n = Replace(Mid(Range("A2"), 19, 5), "年", "") & "-" Range("A1:C2").MergeCells = False Columns("B:B").Select Selection.Insert Shift:=xlToRight Columns("A:A").Select Selection.Insert Shift:=xlToRight Columns("C:C").Select Selection.NumberFormatLocal = "G/標準" Range("B3").Select Selection.AutoFill Destination:=Range("B3:C3"), Type:=xlFillDefault Range("B3").Select ActiveCell.FormulaR1C1 = "商品番号1" Range("C4").Select ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],10)" Range("C4").Select Selection.AutoFill Destination:=Range("C4:C" & e), Type:=xlFillDefault Range("A3").Select ActiveCell.FormulaR1C1 = "抽出年月日" Range("A4").Select ActiveCell.FormulaR1C1 = s & n & 1 Range("A4").Select Selection.AutoFill Destination:=Range("A4:A" & e), Type:=xlFillDefault Rows("3:3").Select Selection.Insert Shift:=xlDown Range("B1:E1").MergeCells = True Range("B2:E2").MergeCells = True ActiveSheet.Name = "提出用" End Sub

  • Excel VBAで表組みしたらデバック発生

    Excel VBAの初心者です。Windows Vistaで Excel2007を使っています。 表をマクロの実行で作成したいと思っています。 何もないエクセルブックより 「開発」→「マクロの記録」→「相対参照」 →「表の作成」→「記録終了」→「相対参照で記録の解除」 →「エクセルマクロ有効ブックで保存」 ところがこのマクロ記録が入ったブックを再度立ち上げ、 表をオールクリアにし、マクロボタンより表作成を実行 させようとすると、次のエラーメッセージがでました。 『実行時エラー'9' インデックスが有効範囲にありません。』 デバックからModule1をみると以下の記述となっていました。 Sub 表組み() ' ' 表組み Macro ' ' ActiveCell.Range("A1:E5").Select Selection.Copy Windows("Book1").Activate ActiveSheet.Paste ActiveCell.Columns("A:A").EntireColumn.Select ActiveCell.Rows("1:1").EntireRow.RowHeight = 11.25 ActiveCell.Rows("1:5").EntireRow.Select Selection.RowHeight = 21.75 ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 14.88 ActiveCell.Offset(0, 4).Range("A1").Select Application.CutCopyMode = False With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With ActiveCell.Offset(1, -3).Range("A1:D4").Select Selection.NumberFormatLocal = "#,##0_ " ActiveCell.Select ActiveCell.FormulaR1C1 = "78000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "102000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "9800" ActiveCell.Offset(-2, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "65000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "204000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "500" ActiveCell.Offset(-2, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "86000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "151000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "10200" ActiveCell.Offset(-2, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(RC[-3]:RC[-1])" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(RC[-3]:RC[-1])" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(0, -3).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(0, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(0, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(-4, -2).Range("A1:D1").Select Selection.AutoFilter End Sub 上から9行目(?)のWindows("Book1").Activateに 黄色い矢印が示され、また行全体が黄色く四角に 覆われていました。 おそらくこの記述に問題があると思いますが、 どんな記述に変えたらいいのか分かりません。 Excel VBAにお詳しい方ご教示願います。 なお、マクロで作成したい図を添付いたします。 参考にしていただければ幸いです。

  • エクセルで繰り返し処理をしたいのですが

    下記のマクロを6行目で展開しています。 これと同じ処理を7行目~36行目めまでさせたいのですが どうやればいいのか教えていただけないでしょうか? sub test() Select Case a Case 2, 3, 4, 5, 6 Range("F6").Select Selection.FormulaR1C1 = _ "=IF(RC[-1]-RC[-2]-0.75-RC[8]-RC[9]<=0,0,RC[-1]-RC[-2]-0.75-RC[8]-RC[9])" Range("H6").Select Selection.FormulaR1C1 = "=IF(-7.75>=RC[9],0,RC[9])" Range("J6").Select Selection.FormulaR1C1 = _ "=IF(IF(RC[-5]<=22,0,(RC[-5]-22-RC[6]))<=0,0,IF(RC[-5]<=22,0,(RC[-5]-22-RC[6])))" Range("B6:W6").Select With Selection.Interior .ColorIndex = 2 .Pattern = xlSolid End With Case 0, 1 Range("F6").Select Selection.ClearContents Range("H6").Select Selection.ClearContents Selection.FormulaR1C1 = "=IF(RC[-5]<=22,0,(RC[-5]-22-RC[6]))" Range("J6").Select Selection.ClearContents Range("B6:W6").Select With Selection.Interior .ColorIndex = 45 .Pattern = xlSolid End With End select End sub

  • ExcelのVBAのAutoFillの使い方について

    Excel97のマクロでAutoFillを使おうとしているのですが、エラーが出て実行できません。 何も表示されていないシートでコマンドボタンを押すと、AutoFillを使ってA1セル~E1セルとA2セル~E2セルに数字の1~5が表示されるようにしたいと考えています。 下記のようにマクロを書いたところ、A1~E5はうまくできたのですが、 「Selection.AutoFill Destination:=ActiveCell.Range("A2:E2"), Type:=xlFillSeries」 の行でエラーが発生します。 「実行時エラー:1004 RangeクラスのAutoFillメソッドが失敗しました。」と表示されます。 Private Sub CommandButton1_Click()   ActiveSheet.Range("A1").Select   ActiveCell.FormulaR1C1 = "1"   Selection.AutoFill Destination:=ActiveCell.Range("A1:E1"), Type:=xlFillSeries   ActiveSheet.Range("A2").Select   ActiveCell.FormulaR1C1 = "1"   Selection.AutoFill Destination:=ActiveCell.Range("A2:E2"), Type:=xlFillSeries End Sub どなたかエラーの原因を教えていただけないでしょうか? よろしくお願いいたします。

  • エクセルVBAでの関数

    下記、コードでセルに関数を入れるようにしてるのですが 関数で得られた値をセルに反映されるようにしたいのですが Dimを使用してもどう指定してよいのかわからず苦戦しております。 宜しくお願い致します。 Range("F1").Select Do Until ActiveCell.Offset(0, -1).Value = ""       With ActiveCell .FormulaR1C1 = "=MID(RC[-1],2,3)" .Offset(1, 0).Select End With Loop Range("A1").Select Do Until ActiveCell.Offset(0, 2).Value = "" With ActiveCell .FormulaR1C1 = "=RC[11]&RC[5]&Rc[8]&rc[9]&rc[3]" .Offset(1, 0).Select End With Loop

  • エクセルVBAの修正をお願いいたします。

    下記VBAをご教授受けて何とか作りましたが、一行指定で作成したのですが、その時によりデータ数にばらつきがありますので、現状データがあるセルだけを拾ってきてデータのあるなしを、JのセルとKのセルに2種類表示するように作成したつもりですが、データがないセルにも延々と Jのセルには 1040272 Kのセルには * が表示されますのでデータが現状ないセルには何も表示されないようにしたいと思います。 自分でいろいろ調べながらしてみるのですが埒が明かない状態になっておりますので、なにとぞお助け、ご教授をお願いいたします。 わかりにくい説明で申し訳ございませんがなにとぞよろしくお願いいたします。 Range("H2").Select ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-5],RC[-4])" Selection.AutoFill Destination:=Range("H2:H10000") Range("H2:H10000").Select Columns("H:H").Select Selection.Copy Columns("I:I").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Replace what:="-", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.Replace what:="_", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Sheets("登録商品リスト").Select Columns("C:C").Select Application.CutCopyMode = False Selection.Copy Columns("E:E").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Replace what:="_", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.Replace what:="-", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("F2").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=UPPER(RC[-1])" Selection.AutoFill Destination:=Range("F2:F10000") Range("F:F").Select Columns("F:F").Select Selection.Copy Columns("G:G").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Sheet2").Select Range("J2").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=COUNTIFS(登録商品リスト!C[-3],C[-1])" Selection.AutoFill Destination:=Range("J2:J1500") Range("J:J").Select Dim i As Long, endRow As Long, str As String, c As Range, wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("登録商品リスト") Set wS2 = Worksheets("Sheet2") endRow = wS2.Cells(Rows.Count, "K").End(xlUp).Row Application.ScreenUpdating = False If endRow > 1 Then Range(wS2.Cells(2, "K"), wS2.Cells(endRow, "K")).ClearContents End If For i = 2 To wS2.Cells(Rows.Count, "I").End(xlUp).Row str = Left(wS2.Cells(i, "I"), 5) Set c = wS1.Range("G:G").Find(what:=str, LookIn:=xlValues, lookat:=xlPart) If Not c Is Nothing Then wS2.Cells(i, "K") = "*" End If Next i Application.ScreenUpdating = True End Sub

  • Excel VBAについて

    以下のコードをFor Nextでまわすには どうしたらよいでしょうか? Sub sample() Range("A2").Select ActiveCell.FormulaR1C1 = "=テスト!R[1]C" Range("A3").Select ActiveCell.FormulaR1C1 = "=テスト!R[3]C" Range("A4").Select ActiveCell.FormulaR1C1 = "=テスト!R[5]C" Range("A5").Select ActiveCell.FormulaR1C1 = "=テスト!R[7]C" Range("A6").Select ActiveCell.FormulaR1C1 = "=テスト!R[9]C" Range("A7").Select ActiveCell.FormulaR1C1 = "=テスト!R[11]C" End Sub

  • VBAでエラーになってしまう

    初心者です。 RangeクラスのSelectメゾットが失敗しました。となります。 このコードは、マクロの記録を行い、そのコードをコマンドボタンのコードにコピーしたものです。 初心者なので、マクロの記録からやりました。 どうか、わかる方がいらっしゃいましたら、教えてください。 Private Sub CommandButton4_Click() Sheets("印刷ページ").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("C6").Select ←ここが黄色くなり、エラーになります。 ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("D6").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("E6").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("B8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("C8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("D8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("E8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("F8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("B10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("C10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("D10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("E10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" End Sub

  • 複数ファイルへのVBAの処理について

    最近、ExcelのVBAを使うようになりました。 しかし、以下のような処理を同じフォルダ内の複数のファイルに対して一気にやりたいのですが、わかる方いらっしゃいませんか? 理想としては同じフォルダ内で50個くらいを選択して一気にやりたいのですが・・・。 ******************************* Sub FFT() Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(18, 1)), TrailingMinusNumbers:=True Range("E8").Select Application.Run "ATPVBAEN.XLA!Fourier", ActiveSheet.Range("$B$1:$B$256"), _ ActiveSheet.Range("$C$1:$C$256"), False, False Columns("C:C").ColumnWidth = 38.38 Range("D1").Select Columns("D:D").ColumnWidth = 20.75 Range("D1").Select ActiveCell.FormulaR1C1 = "=IMABS(RC[-1])" Range("D1").Select Selection.Copy Range("D1:D256").Select ActiveSheet.Paste Range("E6").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "" Range("E7").Select End Sub

専門家に質問してみよう