• 締切済み

エクセル2003マクロの再編集

Sub test() Dim 行1 As Long, 最終行 As Long, 行2 As Long Sheets("Sheet2").Cells.ClearContents Sheets("Sheet1").Activate 最終行 = Range("C65536").End(xlUp).Row 行2 = 1 For 行1 = 1 To 最終行 Sheets("Sheet2").Cells(行2, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Cells(行2, 3).Value = Abs(Sheets("Sheet2").Cells(行2, 3).Value) If Range("A" & 行1).Value = "BBBB1" Then Sheets("Sheet2").Range("A" & 行2) = Range("A" & 行1) & "-1" Sheets("Sheet2").Cells(行2 + 1, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Range("A" & 行2 + 1) = Range("A" & 行1) & "-2" 行2 = 行2 + 1 End If If Range("A" & 行1) = "" Then 行2 = 行2 - 1 Sheets("Sheet2").Range("C" & 行2) = Sheets("Sheet2").Range("C" & 行2) + Range("C" & 行1) End If 行2 = 行2 + 1 Next 行1 End Sub を編集したいのですが全然図りません ご指導お願いします 元データ AAAA5　9601　　950 BBBB1　9660　　150 ASAS9　9654　　-50 AXCW5　9603　　1375 以下の用にマクロで変換する用に出来たのですが 【1】 BBBB1だけではなくAAAA5も対処になったときの 追加方法です 元データは一切変更が出来ません ※フォントの変更も不可です 【2】 元データと変換後データがSheet1からSheet2になっていますが Sheet1の元は範囲はA1～C400で変換後をSheet1E1～G400にしたいのです AAAA5　9601　　950　 BBBB1-1　9660　　150　 BBBB1-2　9660　　150 ASAS9　9654　　50 AXCW5　9603　　1375

みんなの回答

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.1

【１】 BBBB1だけではなくAAAA5も同じ処理をしたいというのであれば、If文の条件を見直すだけではないかと。 ⇒ If a = 1 or b = 2 Then aが1　または　bが2　の時。 【２】 書き出す位置をシート２のＡ～Ｃ列をシート１のＥ～Ｇ列に変更するだけではないかと。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • エクセル2003マクロの機能追加

    Sub test() Dim 行1 As Long, 最終行 As Long, 行2 As Long Sheets("Sheet2").Cells.ClearContents Sheets("Sheet1").Activate 最終行 = Range("C65536").End(xlUp).Row 行2 = 1 For 行1 = 1 To 最終行 Sheets("Sheet2").Cells(行2, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value If Range("A" & 行1).Font.Bold Then Sheets("Sheet2").Range("A" & 行2) = Range("A" & 行1) & "-1" Sheets("Sheet2").Cells(行2 + 1, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Range("A" & 行2 + 1) = Range("A" & 行1) & "-2" 行2 = 行2 + 1 End If If Range("A" & 行1) = "" Then 行2 = 行2 - 1 Sheets("Sheet2").Range("C" & 行2) = Sheets("Sheet2").Range("C" & 行2) + Range("C" & 行1) End If 行2 = 行2 + 1 Next 行1 End Sub 元データ AAAA5　9601　　950 BBBB1　9660　　150 ASAS9　9654　　-50 AXCW5　9603　　1375 以下の用にマクロで変換する機能を追加したいのです AAAA5　9601　　950 BBBB1-1　9660　　150 BBBB1-2　9660　　150 ASAS9　9654　　50 AXCW5　9603　　1375 宜しくおねがいします。

  • エクセル　マクロ　抽出

    教えてください。 ○と記入されたセルを参照して、一つ上のセル・A列にある同じ行のセル・ 9行目にある同じ列のセルを抽出しようとしています。 下記の通り入力すると　行数＝値.Rowでエラーが出たしまいました。 試行錯誤頑張りましたが解決できそうにありませんのでお力を貸して頂けないでしょうか。 Sub 抽出() Dim i, 行数, 列数 As Long Dim 値 As Range i = 0 行数 = 値.Row 列数 = 値.Column For Each 値 In Sheets("sheet1").Range("C12:R171") If 値.Value = "○" Then i = i + 1 With Sheets("sheet2") .Cells(i, 3).Value = Sheets("sheet1").Cells(行数, 1).Value .Cells(i, 4).Value = Sheets("sheet1").Cells(9, 列数).Value .Cells(i, 5).Value = 値.Offset(-1, 0).Value End With End If Next End Sub

  • エクセル　マクロ　チェックボックス

    sheet1にチェックボックスが３つあり、マクロを実行するコマンドボタンが１つあります。 チェックボックスにレ点を入れることにより、sheet4のデータからsheet2にグラフを作成しようと考えてますが、エラーが出てしまい解決できません。 どのように訂正したらいいのか教えて頂けないでしょうか。 Private Sub CommandButton1_Click() Dim GraphRange As String Dim Graph As ChartObject Dim lastRow As Long Set Graph = Sheets("sheet2").ChartObjects.Add(150, 27, 350, 200) lastRow = Sheets("sheet4").Range("A" & Rows.Count).End(xlUp).Row GraphRange = Sheets("sheet4").Range(Cells(1, 1), Cells(lastRow, 1)).Value If Sheets("sheet1").CheckBox1.Value = True Then 'CheckBox1にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 2), Cells(lastRow, 2)).Value End If If Sheets("sheet1").CheckBox2.Value = True Then 'CheckBox2にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 3), Cells(lastRow, 3)).Value End If If CheckBox3.Value = True Then 'CheckBox3にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 4), Cells(lastRow, 4)).Value End If Graph.Chart.ChartWizard Source:=Sheets("sheet4").Range(GraphRange).Value, _ Gallery:=xlLine, Format:=1, PlotBy:=xlColumns, _ CategoryLabels:=1, SeriesLabels:=1, HasLegend:=True End Sub

  • ｅｘｃｅｌ；マクロ；表現をもっと縮小したい

    質問します。下記のようなモジュールで中に同様の数字のみが順に変わるブロック繰り返しが多数あるのですが、もっと簡略化した表現 が可能でしょうか。よろしくお願いします。 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

  • エクセルVBA全シートに差し込みマクロ構文

    Sheets("震圧データ").Select MsgBox "新規ブックに年月分けて" & vbCrLf & "震圧データを転記します、" & vbCrLf & "お待ちください。" Dim c As Range Dim i As Integer Dim LastRow As Long Dim NewSheetName As String, MatchFlag As Boolean Application.ScreenUpdating = False Workbooks.Add With ThisWorkbook.Sheets("震圧データ") For Each c In .Range(.Cells(4, "A"), .Cells(Rows.Count, "A").End(xlUp)) If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月" If c.Row - 2 > Sheets.Count Then Worksheets.Add after:=Worksheets(Worksheets.Count) Else Sheets(c.Row - 2).Select End If ActiveSheet.Name = NewSheetName Sheets(NewSheetName).Range("A1").Value = "年月日" Sheets(NewSheetName).Range("B1").Value = "曜日" Sheets(NewSheetName).Range("C1").Value = "A" Sheets(NewSheetName).Range("D1").Value = "B" Sheets(NewSheetName).Range("E1").Value = "C" Sheets(NewSheetName).Range("F1").Value = "時間" Sheets(NewSheetName).Range("G1").Value = "状態" Sheets(NewSheetName).Range("I1").Value = "No.１" Sheets(NewSheetName).Range("I2").Value = "記録者" Sheets(NewSheetName).Range("I3").Value = "氏名：" Sheets(NewSheetName).Range("I4").Value = "=IF(ISBLANK(A4),"""",DATEDIF("""",Today(),""Y"") & ""歳"")" Sheets(NewSheetName).Range("I5").Value = "=""転載日""" Sheets(NewSheetName).Range("I6").Value = "=TODAY()" Sheets(NewSheetName).Range("I56").Value = "=IF(ISBLANK(A56),"""",""No.2"")" Sheets(NewSheetName).Range("I57").Value = "=IF(ISBLANK(A56),"""",""記録者"")" Sheets(NewSheetName).Range("I58").Value = "=IF(ISBLANK(A56),"""", ""氏名："")" Sheets(NewSheetName).Range("I59").Value = "=IF(ISBLANK(A56),"""",DATEDIF("""",Today(),""Y"") & ""歳"")" Sheets(NewSheetName).Range("I60").Value = "=IF(ISBLANK(A56),"""",""転載日"")" Sheets(NewSheetName).Range("I61").Value = "=IF(ISBLANK(A56),"""",TODAY())" Sheets(NewSheetName).Range("I111").Value = "=IF(ISBLANK(A111),"""",""No.3"")" Sheets(NewSheetName).Range("I112").Value = "=IF(ISBLANK(A111),"""",""記録者"")" Sheets(NewSheetName).Range("I113").Value = "=IF(ISBLANK(A111),"""", ""氏名："")" Sheets(NewSheetName).Range("I114").Value = "=IF(ISBLANK(A111),"""",DATEDIF("""",Today(),""Y"") & ""歳"")" Sheets(NewSheetName).Range("I115").Value = "=IF(ISBLANK(A111),"""",""転載日"")" Sheets(NewSheetName).Range("I116").Value = "=IF(ISBLANK(A111),"""",TODAY())" Sheets(NewSheetName).Range("I166").Value = "=IF(ISBLANK(A166),"""",""No.4"")" Sheets(NewSheetName).Range("I167").Value = "=IF(ISBLANK(A166),"""",""記録者"")" Sheets(NewSheetName).Range("I168").Value = "=IF(ISBLANK(A166),"""", ""氏名"")" Sheets(NewSheetName).Range("I169").Value = "=IF(ISBLANK(A166),"""",DATEDIF("""",Today(),""Y"") & ""歳"")" Sheets(NewSheetName).Range("I170").Value = "=IF(ISBLANK(A166),"""",""転載日"")" Sheets(NewSheetName).Range("I171").Value = "=IF(ISBLANK(A166),"""",TODAY())" Sheets(NewSheetName).Range("H1").Value = "提出済○" Sheets(NewSheetName).Range("A57").Select Range("I6,I61,I116").Select Range("I6,I61,I116,I171").Select Selection.NumberFormatLocal = "yyyy/m/d" Columns("F:F").Select Selection.NumberFormatLocal = "[$-409]h:mm AM/PM;@" Range("G1").Select With Selection .HorizontalAlignment = xlCenter End With LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 8).Value = .Cells(c.Row, "A").Resize(1, 8).Value Sheets(NewSheetName).Columns("A:I").EntireColumn.AutoFit Next 新規ブック最終シートのみ適用できますが他の月別シートに適用できておりません '↓どのような構文にしたら適用されるのでしょうか？ここからが質問です↓ If Sheets(NewSheetName).Range("A56") = "" Then Range("I56:I171").Delete Else Sheets(NewSheetName).Range("A56").Value = "年月日" Sheets(NewSheetName).Range("B56").Value = "曜日" Sheets(NewSheetName).Range("C56").Value = "A" Sheets(NewSheetName).Range("D56").Value = "B" Sheets(NewSheetName).Range("E56").Value = "C" Sheets(NewSheetName).Range("F56").Value = "時間" Sheets(NewSheetName).Range("G56").Value = "状態" End If 'ここまで！　どなたかご教示お願いします .Activate End With

  • エクセル　マクロ　教えてください。

    sheet１に　（a1=No.　b1=月日　C1=項目　d1=収入　e1=支出　f1=摘要　G1=店名）項目を作りそれらをユーザーフォームを作り入力したいです。 この記述では上手く動けません。教えてください。 Private Sub CommandButton1_Click() Dim r As Long, 最終行 As Long, 項目行 As Long Dim re As String r = textboxs1.Value + 10 最終行 = Worksheets("入力").Range("B65536").End(xlUp).Row If r <= 最終行 Then re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _ Chr(13) & "データを置き換えます。　本当に良いですか?　", _ Buttons:=vbYesNo + vbExclamation, Title:="注意!!") If re = vbYes Then With Worksheets("入力") .Cells(r, 2).Activate .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = ComboBox2.Value End With データクリア Exit Sub End If データクリア Exit Sub End If If r >= 最終行 + 1 Then r = 最終行 + 1 End If With Worksheets("入力") .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = CBomboox2.Value End With データクリア End Sub r = データNo + 10 With Worksheets("入力") .Activate .Cells(r, 2).Select TBox1.Value = .Cells(r, 1).Value TBox2.Value = .Cells(r, 2).Value ComboBox1.Value = .Cells(r, 3).Value TBox3.Value = Format(.Cells(r, 4).Value, "###,###") TBox4.Value = Format(.Cells(r, 5).Value, "###,###") TBox5.Value = .Cells(r, 6).Value ComboBox2.Value = .Cells(r, 7).Value End With Exit Sub End If If データNo > 最終行 - 10 Then データNo = 最終行 - 9 TBoxNo.Value = データNo データクリア End If End Sub

  • エクセルのマクロでの質問です

    エクセルのマクロでの質問です。 やりたいことは、 明細シートから、「1.3.5」の条件に合うものを実績シートの最終行にコピーして追加していきたいんです。 これだと、実績シートの最終行にはコピーされるんですが 最終行に全部が上書きコピーされる状態になってしまってます。 どう直せば、追加される形になりますか？ Sub コピー() '1,3,5のものを実績にコピーする i = 5 J = Sheets("実績").Cells(Rows.Count, 4).End(xlUp).Row + 1 Sheets("明細").Select Do While Cells(i, 8).Value <> "" If Cells(i, 3).Value = 1 Or Cells(i, 3) = 3 Or Cells(i, 3) = 5 Then Range("D5", "H5").Copy Sheets("実績").Select Range("C" & J).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End If i = i + 1 Loop End Sub まったくのマクロ初心者です。 分かりやすく教えていただけると、助かります。 また、参考になりそうなサイトなどがあったら、教えてください。

  • エクセル　マクロ：文字変更

    教えてください。 sheet5にデータがあります。 マクロを実行すると、一番右の列のセルに○があると●と書き換える 一番右の列のセルに△があると▲と書き換えるコードを作成しています。 下記のコードでは時間がかかってしまいます。 省略 If Sheets("sheet5").Cells(r, cmax).Value = "○" Then Sheets("sheet5").Cells(r, cmax).Value = "●" 省略 AutoFilterを使用してマクロを作成しましたが、列に○と△が両方無いと 範囲指定したセルがすべて▲となってしまいます。 下記コードをどのように手直ししたらよいのか教えて頂けないでしょうか。 よろしくお願いします。 Sub 文字変更() Dim c As Integer Dim cmax As Integer Dim rmax As Long With Sheets("sheet5") rmax = .Range("A3").End(xlDown).Row cmax = .Range("A3").End(xlToRight).Column .Rows("1:1").Select Selection.AutoFilter For c = 2 To cmax Selection.AutoFilter Field:=c, Criteria1:="○" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "●" Selection.AutoFilter Field:=c, Criteria1:="△" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "▲" Selection.AutoFilter Field:=c Next c End With Selection.AutoFilter End Sub

  • マクロで教えてください。

    sheet1のA列にある図番を参照しsheet2のA列の機種名に適合する行全体に sheet1のB列にある色を塗りたいのですが、マクロを教えていただけますでしょうか？ sheet2のBのセル色を塗るマクロはわかりました。↓です。 Sub macro1() Dim c As Range, myR As Variant With Sheets("Sheet2") For Each c In .Range("a2", .Cells(Rows.Count, "a").End(xlUp)) myR = Application.Match(c.Value, Sheets("sheet1").Columns(1), 0) If Not IsError(myR) Then c.Offset(, 1).Interior.ColorIndex = Sheets("sheet1").Cells(myR, "B").Interior.ColorIndex End If Next End With End Sub 上記マクロですとBセルのみ色が塗られてしまうので行全体を塗るマクロを教えてください。 よろしくお願い致します。

  • Next,End Withのエラー

    Sub 入力() If Sheets("入力").Range("D3").Value = "" Then MsgBox "客先名を入力して下さい" Else Dim K最終行 As Long Dim T最終行 As Long Dim i As Integer With Sheets("入力") For i = 3 To 12 If .Cells(i, "H").Value <> "" Then U最終行 = Sheets("注文書").Range("G65536").End(xlUp).Row + 1 If U最終行 = 461 Then MsgBox "注文書がいっぱいです" Exit Sub Else End If E最終行 = Sheets("営業確認").Range("G65536").End(xlUp).Row + 1 Sheets("営業確認").Range("k" & E最終行).Value = .Cells(i, "b").Value Sheets("営業確認").Range("b" & E最終行).Value = .Cells(i, "c").Value Sheets("営業確認").Range("c" & E最終行).Value = .Cells(i, "d").Value Sheets("営業確認").Range("d" & E最終行).Value = .Cells(i, "e").Value Sheets("営業確認").Range("g" & E最終行).Value = .Cells(i, "h").Value Sheets("営業確認").Range("f" & E最終行).Value = .Cells(i, "i").Value Sheets("営業確認").Range("i" & E最終行).Value = .Cells(i, "m").Value Sheets("営業確認").Range("h" & E最終行).Value = .Cells(i, "p").Value Else End If Select Case .Cells(i, "o").Value Case "北" K最終行 = Sheets("北").Range("h65536").End(xlUp).Row + 1 Sheets("北").Range("B" & K最終行).Value = .Cells(3, "C").Value Sheets("北").Range("c" & K最終行).Value = .Cells(3, "b").Value Case "中" T最終行 = Sheets("中").Range("H65536").End(xlUp).Row + 1 Sheets("中").Range("b" & T最終行).Value = .Cells(3, "c").Value Sheets("中").Range("c" & T最終行).Value = .Cells(3, "b").Value End Select Exit Sub Dim Dummy As Worksheet Dim SheetName As String Dim OTA As Long Dim GEN As Long Dim SheetName2 As String With Sheets("入力") '3行目～22行目まで For j = 3 To 22 SheetName = Sheets("入力").Range("D3").Value On Error Resume Next Set Dummy = Sheets(SheetName) SheetName2 = .Cells(i, 14).Value 'もしシートがあれば・・・ If Err.Number = 0 Then 'SheetName2は入力シートのN行 SheetName2 = .Cells(i, 14).Value OTA = Sheets(SheetName2).Range("B65536").End(xlUp).Row + 1 Sheets(SheetName2).Range("A7").Value = .Cells(3, "D").Value Sheets(SheetName2).Range("C3").Value = .Cells(3, "C").Value Sheets(SheetName2).Range("B" & OTA).Value = .Cells(i, "H").Value Sheets(SheetName2).Range("I" & OTA).Value = .Cells(i, "I").Value Sheets(SheetName2).Range("F" & OTA).Value = .Cells(i, "K").Value Sheets(SheetName2).Range("H" & OTA).Value = .Cells(i, "L").Value Sheets(SheetName2).Range("J" & OTA).Value = .Cells(i, "M").Value 'シートが無ければ・・・ Else GEN = Sheets("原紙").Range("B65536").End(xlUp).Row + 1 Sheets("原紙").Range("A7").Value = .Cells(3, "D").Value Sheets("原紙").Range("C3").Value = .Cells(3, "C").Value Sheets("原紙").Range("B" & GEN).Value = .Cells(i, "H").Value Sheets("原紙").Range("I" & GEN).Value = .Cells(i, "I").Value Sheets("原紙").Range("F" & GEN).Value = .Cells(i, "K").Value Sheets("原紙").Range("H" & GEN).Value = .Cells(i, "L").Value Sheets("原紙").Range("J" & GEN).Value = .Cells(i, "M").Value '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName Next End With Exit Sub On Error GoTo 0 Sheets("原紙").Select Range("C3:E3,A7,B16:B35,F16:F35,H16:J35").Select Range("H35").Activate Selection.ClearContents Sheets("入力").Select Sheets("入力").Range("D3,G3:J12,L3:M12").Value = "" Sheets("入力").Range("D3").Select Range("B3").Formula = "=IF(D3="""","""",VLOOKUP(D3,'\\Seika-sv01\支店共有\マーケティング用\[担当者リスト.xls]リスト形式'!$B:$D,3,FALSE))" MsgBox "入力が完了しました" End If End Sub 上記のようにマクロを組みましたがエラーが出てしまいます。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する