エクセルのマクロで連番を取得する方法

このQ&Aのポイント
  • エクセルのマクロを使用して、Retsu1の値に連番を書き込む方法について教えてください。
  • Retsu1の値が変化するたびに1から始まる連番をRetsu2に書き込む方法を教えてください。
  • マクロ初心者であるため、Gyou, Retsu1, Retsu2の宣言までしかできていません。続きのマクロを教えてください。
回答を見る
  • ベストアンサー

通し番号(連番)を返すマクロ

エクセルで -------------------        | Retsu1 | Retsu2 | ------------------- Gyou    |    1 |    1  | -------------------         |    1  |    2  | -------------------        |     1 |    3  | -------------------        |     2 |    1  | このようにRetsu1には1~Xの数字が入っています。 データはRetsu1で並べ替えをしているため、その数字は、しばらく1が続いたら、次は2が続き、その次には3が続くというような並び方をしています。X(最終の数字)が続いた後は空白です。 そこで、Retsu2には1,2,3・・・というように連番を書き込みたいと思います。 これはRetsu1の同一数字内で連番にしたいのです。 つまり、Retsu1の値が2になれば、また新たに1,2,3・・・というような感じです。 最後にはRetsu1の値がXで1,2,3・・・と連番の書き込みが終わったら(Retsu1が空白になったら) Retsu2への書き込みも終了とします。 マクロ初心者のため Dim Gyou As Integer Dim Retsu1 As Integer Dim Retsu2 As Integer までしかできていません。 この続きのマクロを教えてください。お願いします。

  • oonots
  • お礼率88% (160/181)

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

  • ベストアンサー
  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.2

こんばんは! 色々方法はあるかと思いますが、 一例です。 個人的に For~Next を使うのが好きなので・・・ データはA列の2行目からあるとします。 Sub test1() Dim i As Long If Cells(2, 1) <> "" Then Cells(2, 2) = 1 End If For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 1) = Cells(i - 1, 1) Then Cells(i, 2) = Cells(i - 1, 2) + 1 Else Cells(i, 2) = 1 End If Next i End Sub こんな感じではどうでしょうか?m(__)m

oonots
質問者

お礼

ご回答ありがとうございました。 役に立ちました。また,勉強にもなりました。 For~Nextは初心者でも理解しやすくていいですね。 これからも頑張ってみます。

その他の回答 (2)

  • mu2011
  • ベストアンサー率38% (1910/4994)
回答No.3

関数の方が簡単なのでマクロにしなくてもよいのではないでしょうか。 Retu2の先頭に=COUNTIF($A$1:A1,A1)として下方向にコピーしてみて下さい。

oonots
質問者

お礼

ご回答ありがとうございました。 役に立ちました。また,勉強にもなりました。 ただ,今回はマクロで実行しようと考えています。 関数でも簡単にできるんですね。

  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

1行目にタイトル行,2行目からデータ A列にグループ番号 B列に123123として sub macro1()  with range("B2:B" & range("A65536").end(xlup).row)   .formula = "=IF(A1<>A2,1,SUM(B1,1))"   .value = .value  end with end sub

oonots
質問者

お礼

ご回答ありがとうございました。 役に立ちました。また,勉強にもなりました。

関連するQ&A

  • 2つのシートの比較で更新分だけを色付けしたい

    表を管理していて、前月のある日に保存した内容と 翌月のある日に保存した内容を比較して 差分を取りたいのです。 例えば、表を更新した時に行が追加されたりして レコードはひとつ追加になっているけれど 他の内容は変わってないとします。 しかし、同じ位置の同じセルの値を比較だと 追加した行以降全てのセルに色が付いてしまいます。 これを、追加された行(レコード)だけを 色付けるようにしたいのです。 >If s1.Cells(gyou, retsu).Value <> s2.Cells(gyou, retsu).Value Then > > '同じ位置のセルの値が等しくなければ、そのセルを赤で塗りつぶす。 この部分に手を加えればいいのかと思うのですが、解りません。 どのようにすればいいのか教えていただけないでしょうか? お願いいたします。 Sub シート比較()  Dim RETSU_S, RETSU_E, GYOU_S, GYOU_E As Long RETSU_S = 1 RETSU_E = 10 GYOU_S = 2 GYOU_E = 101   Dim s1, s2 As Worksheet  Set s1 = Worksheets("Sheet1")  Set s2 = Worksheets("Sheet2") Dim retsu, gyou As Long 'この変数で列と行を指定する For gyou = GYOU_S To GYOU_E For retsu = RETSU_S To RETSU_E If s1.Cells(gyou, retsu).Value <> s2.Cells(gyou, retsu).Value Then '同じ位置のセルの値が等しくなければ、そのセルを赤で塗りつぶす。 s1.Cells(gyou, retsu).Interior.ColorIndex = 3 s2.Cells(gyou, retsu).Interior.ColorIndex = 3 End If Next Next End Sub

  • Excel VBA データの入っているセルの取り出し

    Excel VBA データの入っているセルの取り出し Excel2007使用です。 大きなセル範囲の中にデータが点在している場合に、そのデータを一か所にまとめるマクロを作りたいです。セル範囲は決まっています(A1:Q100)。最終的には隣のセルの1列にまとめたいです。 以下のようなマクロを作ってみましたが、いずれも作動しませんでした(エラーメッセージも出ず) NullをEmptyに変えてみても同じでした。 (ややこしいですが、アクティブセルはSheet2、Sheet1へ貼り付けたい) (とりあえずシート内で列上部にまとめようとした) Dim myRange As Range For Each myRange In Range("A1:Q100") If myRange.Value = Null Then myRange.Delete xlShiftUp End If Next myRange End Sub (1行1列ずつの参照をループさせて「空白でない」セルを切り取り-貼り付けさせようとした) Worksheets("sheet2").Activate Dim Gyou As Integer Dim Retsu As Integer For Gyou = 1 To 100 For Retsu = 1 To 17 If Cells(Gyou, Retsu).Value = Not Null Then Cells(Gyou, Retsu).Cut Destination:=Worksheets("sheet1").Cells(5, 2) End If Next Retsu Next Gyou End Sub また、以下のマクロは、実行すると現状のままSheet1のE列以降に移るだけで、データのあるセルだけがまとまるという状態にはなりません。 Range("A1:Q100").SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Sheet3").Range("E1") End Sub 以下は某サイトで、まさに「空白セルを削除しデータの入ってるセルを上詰めにする」というマクロが紹介されていたので、加工してやってみましたが、「RangeクラスのDeleteメソッドが失敗しました」という実行時エラーが出てできませんでした。 Dim WS As Worksheet Dim myRng As Range Dim Lrow As Long Set WS = Worksheets("Sheet1") Lrow = WS.Range("A" & CStr(Rows.Count)).End(xlUp).Row Set myRng = WS.Range("A1:A" & CStr(Lrow)) myRng.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp End Sub データの入っているセルだけを取り出して一つの列にまとめたいのですが、どうしたらいいのでしょうか。

  • 年月-連番を付与するマクロを教えて下さい。

    連番を付与するマクロを教えて下さい。 初心者です。 B列に値が入ったタイミングでA列に今日の年月-01の連番を付けたいと思います。 年は西暦の下2桁月2桁-数字2桁 1401-01 できれば月が変わったら連番も01スタートなら最高です。 1401-01 1401-02 1402-01 こんな感じです。 B列には下に値が無ければ順番に下の行に値が入るマクロが入っています。 初心者ゆえ説明もわかりにくいかと思いますが、よろしくお願いします。

  • VBAの連番の振り方について

    セルC1からC10まで罫線の表があり、inputboxで入力された数値だけD列以降にコピペされ、 セルC1をスタートに C1が1、D1が2、E1が3・・・といったように、連番を振りたいのですが、 下記プログラムで実行すると、inputboxで入力された数値分、表はコピペされますが、 肝心な連番が振られず1行目は空白のままになってしまいます。 ------------------------------------------------------------------------------ Dim cp As Long, x As Integer Dim ren As Integer 答え1 = InputBox("拠点数を入力してください。", "拠点数入力") ia = Val(答え1) Application.ScreenUpdating = False Range("C1:C10").Copy For cp = 1 To ia - 1 Cells(1, x + 4).PasteSpecial x = x + 1 Next With Application .CutCopyMode = False .ScreenUpdating = True End With ren = 1 Range("C1").Select Do While ActiveCell.Offset(0, 1).Value <> "" ActiveCell.Value = ren ren = ren + 1 ActiveCell.Offset(1).MergeArea.Select Loop どう修正すれば良いのか分かりません。 宜しくお願い致します。

  • マクロが動作しない

    Office2003にバージョンアップすると動作しないマクロが出ました。ちゃんと動作するものもあります。 内容は変更していないので内容はあってるはずですが 念のためコピーします。 Sub 電装品() Dim Gyou As Integer Dim Gyouz As Integer Dim State As Integer Dim Statez As Integer Dim CelValue As String Dim CelValuez As String Dim CopyCelNo As String Dim CopyCelNoz As String Dim WS1 As Object Dim WS2 As Object Set WS1 = Worksheets("購入品リスト") Set WS2 = Worksheets("電装品リスト") WS2.Range("A:G").Delete Shift:=xlToLeft WS2.Range("B1") = "電 装 品 リ ス ト" With WS2.Range("B1") .Font.Bold = True .Font.Italic = True .Font.Size = 24 End With WS2.Range("D1") = "作成日:" & Date WS1.Range("C3:E3").Copy (WS2.Range("A2:C2")) State = 3 For Gyou = 1 To 2000 CopyCelNo = "A" & State CelValue = WS1.Cells(Gyou, 17).Value If CelValue = "1" Then WS1.Range(WS1.Cells(Gyou, 3), WS1.Cells(Gyou, 5)).Copy (WS2.Range (CopyCelNo)) State = State + 1 End If Next WS1.Range("G3:J3").Copy (WS2.Range("D2:G2")) Statez = 3 For Gyouz = 1 To 2000 CopyCelNoz = "D" & Statez CelValuez = WS1.Cells(Gyouz, 18).Value If CelValuez = "1" Then WS1.Range(WS1.Cells(Gyouz, 7), WS1.Cells(Gyouz, 10)).Copy (WS2.Range (CopyCelNoz)) Statez = Statez + 1 End If Next End Sub

  • シートの増減あっても特定セルに連番したい

    Excel2007でマクロ作成の初心者です。 すべてのシートのR15セルに、シートの順番どおり 1から連番で番号をつけるマクロを教えていただきました。 Private Sub Workbook_SheetActivate(ByVal Sh As Object) Dim i As Integer For i = 1 To ThisWorkbook.Worksheets.Count Worksheets(i).Range("R15").Value = i Next i End Sub これを以下のように改良したのですが、新しく追加したシートにはなぜか 番号が表示されません。どうしたら、うまく連番が入るようになるでしょうか。 Sub シートに連番() Dim i As Integer For i = 1 To ThisWorkbook.Worksheets.Count Worksheets(i).Range("R15").Value = i Next i End Sub

  • エクセルのマクロで exit について

    よろしくおねがいします 各々のシートのX1セルを値を参照して ゼロ以外の時は 印刷の処理をして ゼロの時は処理をしない という内容を書きたく思います。 このままで記述だとX1セルの値がゼロの場合 いきなりsubを抜けてしまうのですが 1,2枚目でゼロの場合 その次のシートにきちんと処理が 継続したいのですが どこを修正したらよろしいでしょうか? Sub マクロ() Dim shAry As Variant Dim i As Integer, cnt As Integer, x As Integer shAry = Array("東京", "千葉", "群馬") For cnt = LBound(shAry) To UBound(shAry) Sheets(shAry(cnt)).Select x = Int(((Range("x1").Value) - 1) / 5) + 1 If x = 0 Then GoTo ゼロの場合の処理 Else MsgBox "印刷枚数は " & x & "枚です" ここにいんさつの処理があります End If Next Exit Sub ゼロの場合の処理: MsgBox "印刷する内容はありません" End Sub

  • エクセルのマクロについて

    お手数ですが誰か教えてください! BのデーターをAに集計するマクロを作ったのですが 処理速度とっても遅いのです。 高速で処理する方法はありませんでしょうか? 私が作ったマクロ Sub 集計() Dim Z As Integer Dim i As Integer Dim X As Integer For Z = 2 To 2000 For i = 2 To 2000 For X = 3 To 20 If Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) And       Worksheets("A").cells(1, X) = Worksheets("B").cells(i, 14) Then Worksheets("A").cells(Z, X) = Worksheets("B").cells(i, 16) End If Next X Next i Next Z End Sub       どこかが間違っている気がしますがマクロ初心者のため       先に進めません。       どうかご教授よろしくお願い致します。

  • 階乗のマクロ

    階乗のマクロを作りたいのですが、全然できません。どこを変えたらいいのか教えて下さい。ちなみに今こうなっています。 ------------------------------------------------ Sub exam5() Dim intA As Integer Dim intB As Integer Dim intC As Integer intA = Application.InputBox("数値を入力してください。") intB = (intA - 1) intC = (intA) * (intB) MsgBox (intC) End Sub Function kaijou(intA As Integer, intB As Integer) As Integer kaijou = intA * intB End Function ------------------------------------------------ どうかお願いします。

  • VBAで縦一列に数字を入力したい

    Private Sub CommandButton1_Click() Dim n As Integer Dim i As Integer Dim x As Integer For i = 1 To n x = i + 3 n = InputBox("層数の値を入力してください") Cells(3, 1).Value = ("基板") Cells(x, 1).Value = i x = x + 1 Next End Sub 上記のようなマクロを組んだのですが、4行目に1が入ってとまってしまいました。 これを完成させるにはどうしたらいいでしょうか?

専門家に質問してみよう