こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

VBA初心者です。プログラム教えてください。

行1にA~Kの値があり、この範囲で、A列に同じ値が入っている限り1、2、3と始まる値が入るよう処理をする。A列の値が変ったら、また1からスタートする値が入るよう処理をしたい。


Sub Work()

Dim M As Integer
Dim N As Integer

M = 2
N = 2

Do While Cells(2 ,N) <> ""
Cells(3 , N) <> "" Or C = Cells(3 , N - 1)  (1)
N = N + 1
Loop

End Sub

上記を作りましたが、(1)の所でデバックしてしまいます。
解決策をぜひ教えてください。よろしくお願いします。

投稿日時 - 2007-09-15 19:50:02

QNo.3347757

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(9)

ANo.9

こんばんは。

>今回はLoopを使いたかったのですが、とても参考になりました。

原則的に、Loopで、最終行の判定をセル1つずつとれば、遅くなりますので、通常、Do ~Loop は、大量のセルの判定には使いません。少量に限ります。なお、Do ~ Loopの使い方のほうが難しいです。

また、以下のコードでは、本来は、不要ですが、罫線などは、自分以外の環境の時は、極力、プロパティの省略は避けることにしています。しかし、個々の線は、コレクションとしてまとめてよいということです。罫線を使うと、とたんにスピードが遅くなりますから、それなりにコードの工夫は必要です。まあ、後学のために。

'標準モジュール

Sub PlusLineDrawing()
  Dim c As Range
  Dim N As Long
  Dim rng As Range
  Set rng = Range("A2", Range("A65536").End(xlUp))
  Application.ScreenUpdating = False
  '省略は避けます
  With rng.Offset(, 1).Resize(, 11)
    .Borders.LineStyle = xlNone
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlThin
    .Borders.Color = vbBlack
  End With
  N = 0
  For Each c In rng
    c.Offset(, 1).Resize(, 11).FormulaLocal = "=" & N & "+COLUMN(A1)"
    c.Offset(, 1).Resize(, 11).Value = c.Offset(, 1).Resize(, 11).Value
    If StrComp(Trim(c.Value), Trim(c.Offset(1).Value), 1) = 0 Then
      N = WorksheetFunction.Max(c.Offset(, 1).Resize(, 11))
    Else
      N = 0
      'オプション--最後を太線にするか、そのままにするか?
      'If c.Row = rng.Cells(rng.Count).Row Then Exit For '太線
      c.Offset(, 1).Resize(, 11).Borders(9).Weight = xlMedium
    End If
  Next c
  Set rng = Nothing
  Application.ScreenUpdating = True
End Sub

投稿日時 - 2007-09-18 00:36:38

お礼

ご丁寧にありがとうございました。もう少し上達して、こちらのプログラムも勉強したいと思います。

投稿日時 - 2007-09-18 20:13:27

ANo.8

#1です。罫線追加バージョンです。

Dim Col As Integer
Dim Col2 As Integer
Dim Line As Long
Dim Cnt As Long

Col = 2
Line = 2
Cnt = 0

Cells.Select
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select

Do While Cells(Line, 1) <> ""
Do While Cells(1, Col) <> ""
Cnt = Cnt + 1
Cells(Line, Col) = Cnt
Col = Col + 1
Col2 = Col
Loop
Line = Line + 1
Col = 2
If Cells(Line, Col - 1) <> Cells(Line - 1, Col - 1) Then
Cnt = 0
Range(Cells(Line - 1, 2), Cells(Line - 1, Col2 - 1)).Borders(xlEdgeBottom).Weight = xlMedium
Else
Range(Cells(Line - 1, 2), Cells(Line - 1, Col2 - 1)).Borders(xlEdgeBottom).Weight = xlThin
End If
Loop

Range(Cells(2, 1), Cells(Line - 1, Col2)).Borders(xlInsideVertical).Weight = xlThin
Range(Cells(2, 2), Cells(Line - 1, Col2 - 1)).Borders(xlEdgeTop).Weight = xlThin
Range(Cells(2, 2), Cells(Line - 1, Col2 - 1)).Borders(xlEdgeBottom).Weight = xlThin

投稿日時 - 2007-09-17 16:39:43

お礼

ありがとうございました。お蔭様で支障なく業務に関われそうです。
また何か問題がありましたら、どうぞ宜しくお願い致します。

投稿日時 - 2007-09-18 20:11:55

ANo.7

こんにちは。

難しく考えないで、数式で作ればよいのではありませんか?
私の場合は、文字の比較に対して、TextCompare を用いています。
Aもa も、全角のAもaも同じだとします。


Sub NumberingTest1()
Dim c As Range
Dim N As Long

N = 0

For Each c In Range("A2", Range("A65536").End(xlUp))
 c.Offset(, 1).Resize(, 11).FormulaLocal = "=" & N & "+COLUMN(A1)"
 '定数化
 c.Offset(, 1).Resize(, 11).Value = c.Offset(, 1).Resize(, 11).Value
 '文字列比較
 If StrComp(Trim(c.Value), Trim(c.Offset(1).Value), 1) = 0 Then
   N = WorksheetFunction.Max(c.Offset(, 1).Resize(, 11))
 Else
   N = 0
 End If
Next c
End Sub

投稿日時 - 2007-09-16 13:05:50

お礼

ありがとうございます。今回はLoopを使いたかったのですが、とても参考になりました。Wendy02様の方法は別の機会に参考にさせていただきたいと思います。

投稿日時 - 2007-09-17 14:56:54

ANo.6

#1です。#4氏が既に回答されていますが、私はLoopを使う方法ということで...

Dim Col As Integer
Dim Line As Long
Dim Cnt As Long

Col = 2
Line = 2
Cnt = 0

Do While Cells(Line, 1) <> ""
Do While Cells(1, Col) <> ""
Cnt = Cnt + 1
Cells(Line, Col) = Cnt
Col = Col + 1
Loop
Line = Line + 1
Col = 2
If Cells(Line, Col - 1) <> Cells(Line - 1, Col - 1) Then
Cnt = 0
End If
Loop

以上です。

投稿日時 - 2007-09-16 11:02:48

補足

ありがとうございました。思う通りにできました。
また併せて教えていただきたいのですが、罫線を引く場合の設定はどのようにしたらいいのでしょうか。

希望はB2セルから値が入ってる部分を細線で格子状にしたいのです。
またA1列の値が変る部分(aとbの行の境目)を太線にしたいのですが、


With Selection

 Range(Cells(2,Line),Cells(Col,2)).Select

  Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  Selection.Borders(xlEdgeLeft).LineStyle = xlNone
  Selection.Borders(xlEdgeTop).LineStyle = xlNone
  Selection.Borders(xlEdgeBottom).LineStyle = xlNone
  Selection.Borders(xlEdgeRight).LineStyle = xlNone
  Selection.Borders(xlInsideVertical).LineStyle = xlNone
  Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End With

では作動しませんでした。よろしくお願いいたします。

投稿日時 - 2007-09-17 14:53:51

ANo.5

#3です。

#4さんへの補足&回答を見て書いています。
回答者はシート内容を見ている訳ではないので、このように座標と結果が視覚的に解ると答えやすいです。

Do ~ Loop を使う方法ではありませんが、参考まで。


Sub Test()
Dim cnt As Long, myRow As Long, myCol As Integer
 'カウント変数を初期化
 cnt = 1
 With ActiveSheet
  'A2からCtrl+↓のA列最終行までループ
  For myRow = 2 To .Cells(2, 1).End(xlDown).Row
   'B列からL列までループして連番を代入
   For myCol = 2 To 12
     .Cells(myRow, myCol).Value = cnt
     cnt = cnt + 1
   Next myCol
   '次の行に移る前にA列の文字を判定し、違っていたらCntを初期化
   If .Cells(myRow, 1).Value <> .Cells(myRow + 1, 1).Value Then
     cnt = 1
   End If
  '次の行へ
  Next myRow
 End With
End Sub

投稿日時 - 2007-09-16 10:49:15

お礼

参考になります。次の機会にぜひ使わせていただきたいと思います。ありがとうございました。

投稿日時 - 2007-09-17 15:00:15

ANo.4

再度#1です。しつこくて申し訳ないです。
#3氏の補足に書かれたものもみましたが、やはり質問者様の意図するところが見えません。

行1のA~Kの値というのは、範囲を示しているだけで、ナンバリングの条件には関係ないのですね?
c1とかr1とか新しい情報(条件)も出てきてますので、まだ問題が解決されていないようなら、改めて条件の整理をお願いします。

・A列の値により付与する1、2、3~という値はどのセル(どの列)に入れたいのでしょうか?B列ですか?
・A列から1列おきにK列までaa,bbb,ccって入れてあるから、間の空白列にナンバリングしたいってことですか?

投稿日時 - 2007-09-16 00:36:00

補足

こちらこそ説明不足ですみません。
条件は下記のようになります。

 A  B  C  D  E  F  G  H  I  J  K
a1  2  3  4  5  6  7  8  9  10 11
a12







投稿日時 - 2007-09-16 09:42:26

お礼

誤って上記を転送してしまいましたので、こちらに補足させていただきます。

A~K列はセルB1~L1にあります。また縦方向のa、b、cはA2セルから始まります。

  A   B  C  D   E  F  G  H  I  J  K
a 1  2  3  4  5  6  7  8  9  10 11
a 12 13  14 15 16 17 18 19 20  21 22
b 1  2  3  4  5  6  7  8  9  10 11
c 1  2  3  4  5  6  7  8  9  10 11
d 1  2  3  4  5  6  7  8  9  10 11
d 12 13  14 15 16 17 18 19 20  21 22

のようにしたいのです。A2セルの値が変ったら数字は1から始まる。
どうぞよろしくご指導ください。

投稿日時 - 2007-09-16 10:11:01

ANo.3

ご質問に「1行目に A~K の値が入っている」「A列の値が変わったら」とありますが、

 N = 2
 Do While Cells(2 ,N) <> ""
   Cells(3 , N) <> "" Or C = Cells(3 , N - 1)

上記コードを見る限り 1行目も A列もほとんど無視して、セル B2 と B3 と A3を起点に処理をしようとしていますね。

B1~I1 に A,A,B,B,B,C,C,C と値があった場合、
B2~I2 に 1,2,1,2,3,1,2,3 と番号を振りたい

のように、セル座標を提示して質問された方が回答者の環境で再現させやすいと思いますよ。
仮に上記の条件だとしたら

Sub Test()
Dim N As Integer, M As Integer
M = 1
With ActiveSheet
  For N = 2 To .Cells(1, 256).End(xlToLeft).Column
    If .Cells(1, N).Value = .Cells(1, N - 1).Value Then
      M = M + 1
    Else
      M = 1
    End If
      .Cells(2, N).Value = M
  Next N
End With

End Sub

投稿日時 - 2007-09-15 22:51:09

補足

C1に縦方向にa,a,a,b,bなどを、またR1に横方向にA、B、Cと入力したいので、起点はB2セルになります。

そのような表現がわかりやすいのですね、ご指摘いただいてありがとうございました。

投稿日時 - 2007-09-15 23:53:29

ANo.2

#1です。
意味が今一理解できないといったのは、A~Kの値が横にならんでいるのか、縦に並んでいるのかです。

「行1にA~Kの値があり」だと横に並んでいるし、
「A列に同じ値が入っている限り」だと縦に並んでいることになります。
お書きになっているCellsの書き方だと列方向に変数が使われていますので、横方向に並んでいると想定します。

そうすると、以下のコードでOKなはずです。

Dim N As Integer

N = 1

Do While Cells(1, N) <> ""
If N = 1 Then
Cells(2, N) = 1
Else
If Cells(1, N) = Cells(1, N - 1) Then
Cells(2, N) = Cells(2, N - 1) + 1
Else
Cells(2, N) = 1
End If
End If
N = N + 1
Loop

ワークシート関数を使うなら、a2セルには初期値として1を入力しておき、B2のセルに=If(b1=a1,a2+1,1)と入力し、それを横にコピーしていけばできます。

投稿日時 - 2007-09-15 22:49:09

補足

説明不足でもうしわけありません。ご指摘の通り、「行1」に横方向にアルファベットをKまで並べてあります。また「列A」にも上から縦にアルファベットがありまして、こちらはa、bなどの表記にすればよかったのですね。失礼いたしました。

投稿日時 - 2007-09-15 23:45:04

ANo.1

直接の原因は(1)の行が、If ~ Then ~ Else ~ End If の形になっていないからだと思います。
それとCという変数の宣言や値設定もありませんね。

あと「行1にA~Kの値があり~~」の意味が今一理解できませんので、ピンとはずれかもしれませんが、
=IF(a2<>a1,1,a1+1)というワークシート関数はダメ?

投稿日時 - 2007-09-15 20:06:24

補足

(1)のCはNの間違いでした。すみません。

Cells(3 , N) <> "" Or N = Cells(3 , N - 1) です。

ここを

If N <> "" Then

Else

End If

でしょうか。Elseの前と後にはどのような条件を入れたらいいですか?

1行目にA,B,C・・・J,Kまでの値が入っている状態です。説明不足で申し訳ありません。関数を使ったらどのようになるのでしょうか?その場合でもVBAでできますか?

投稿日時 - 2007-09-15 20:19:36

あなたにオススメの質問