• 締切済み

配列表示と間引き

配列の間引きをを教えて下さい。 下記文を書きました Sub 配列() Dim u As Integer '左 Dim v As Integer '中 Dim w As Integer '右 Dim x As Integer '左 Dim y As Integer '中 Dim z As Integer '右 Dim row As Integer '行カウンタ Dim col As Integer '列カウンタ Dim intSheet As Integer 'シートカウンタ Dim blnNextPage As Boolean '次シートフラグ '初期値セット u = 1 v = 2 w = 3 x = 4 y = 5 z = 5 row = 0 col = 1 intSheet = 1 Do While (1) 'zカウント z = z + 1 If z > 20 Then 'zが20以上ならy+1 y = y + 1 If y > 19 Then 'yが20以上ならx+1 x = x + 1 If x > 18 Then 'xが20以上ならy+1 w = w + 1 If w > 17 Then 'wが20以上ならx+1 v = v + 1 If v > 16 Then 'wが20以上ならx+1 u = u + 1 '終了条件 If (x = 19 And y = 19 And z = 20) Then Exit Do 'v初期化 = x+1 v = u + 1 End If 'w初期化 = y+1 w = v + 1 End If 'x初期化 = x+1 x = w + 1 End If 'y初期化 = y+1 y = x + 1 End If 'z初期化 = y+1 z = y + 1 End If If z > 20 Then Exit Sub '行カウント row = row + 1 If row > 1000 Then '1000で次の列か次のページへ If blnNextPage Then '行・列カウンタ初期化 col = 1 row = 1 '次のシートへ intSheet = intSheet + 1 '次のシートが無い場合は追加 If intSheet > Worksheets.Count Then Sheets.Add After:=Worksheets(Worksheets.Count) End If 'シートをアクティブに Worksheets(intSheet).Select 'フラグ消去 blnNextPage = False Else '次の列へ col = col + 6 row = 1 'blnNextPage = True End If End If If col = 6 * 3 + 1 Then blnNextPage = True End If 'データ表示 Worksheets(intSheet).Range(Chr(64 + col) & row).Cells = u Worksheets(intSheet).Range(Chr(64 + col + 1) & row).Cells = v Worksheets(intSheet).Range(Chr(64 + col + 2) & row).Cells = w Worksheets(intSheet).Range(Chr(64 + col + 3) & row).Cells = x Worksheets(intSheet).Range(Chr(64 + col + 4) & row).Cells = y Worksheets(intSheet).Range(Chr(64 + col + 5) & row).Cells = z Loop End Sub 上記文で表示をしますが、 ６列目までの間に３列の連数字の時には表示を行わず、次に移る様にしたいのですが、どうすれば良いでしょうか？ 1,2,5,6,10,12はOKです 1,2,3,5,6,10又は1,3,4,5,10,11等３連の数字は表示を行わない。

みんなの回答

  • pkh4989
  • ベストアンサー率62% (162/260)
回答No.1

以下のように追加してみてください。 　　　　'３列の連数字チェック 　　　　If Chk_Pass(u, v, w, x, y, z) Then　　　　　　　'←追加 　　　　　　row = row - 1　　　　　　　　　　　　　　　 '←追加 　　　　Else　　　　　　　　　　　　　　　　　　　　　　'←追加 　　　　　　'データ表示 　　　　　　Worksheets(intSheet).Range(Chr(64 + col) & row).Cells = u 　　　　　　Worksheets(intSheet).Range(Chr(64 + col + 1) & row).Cells = v 　　　　　　Worksheets(intSheet).Range(Chr(64 + col + 2) & row).Cells = w 　　　　　　Worksheets(intSheet).Range(Chr(64 + col + 3) & row).Cells = x 　　　　　　Worksheets(intSheet).Range(Chr(64 + col + 4) & row).Cells = y 　　　　　　Worksheets(intSheet).Range(Chr(64 + col + 5) & row).Cells = z 　　　　End If　　　　　　　　　　　　　　　　　　　　　'←追加 　　Loop End Sub '３列の連数字チェック Function Chk_Pass(u As Integer, v As Integer, w As Integer, x As Integer, y As Integer, z As Integer) 　　Dim wVal(6)　　 As Integer 　　Dim wI　　　　　As Integer 　　Dim wCnt　　　　As Integer 　　' 　　Erase wVal 　　wVal(1) = u 　　wVal(2) = v 　　wVal(3) = w 　　wVal(4) = x 　　wVal(5) = y 　　wVal(6) = z 　　' 　　wCnt = 1 　　For wI = 2 To 6 　　　　If wVal(wI - 1) + 1 = wVal(wI) Then 　　　　　　wCnt = wCnt + 1 　　　　　　If wCnt >= 3 Then 　　　　　　　　Exit For 　　　　　　End If 　　　　Else 　　　　　　wCnt = 1 　　　　End If 　　Next 　　If wCnt >= 3 Then 　　　　Chk_Pass = True 　　Else 　　　　Chk_Pass = False 　　End If End Function

WCA_goo
質問者

お礼

有り難うございます 出来ました

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • ※ＶＢＡ配列

    http://oshiete1.goo.ne.jp/qa5196795.htmlで 質問させてもらった者です。質問不足だったため 質問の内容を追加したかったのですが、追加の方法がわからず またこちらで質問させていただきました Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub a～tの文字が、上記のような動きをする プログラムを作成するにはどのように配列を活かせばいいですか? 配列がよくわかっておらず勉強したのですが…使えずにいます；;

  • ●Ｅｘｃｅｌ　ＶＢＡ　配列●教えて下さい

    a～tの文字が順々に文字を追っていくプログラムにしたいと思い 配列を使用したのですが…プログラムが稼動しません、 下記のプログラムでは何が足りないのでしょうか わかる方いたら教えて下さい; 配列の使い方についてアドバイスがあれば そちらも教えていただきたいです…。 '――ここから―― Dim time1 As Integer, time2 As Integer, n As String Dim X As Integer, Y As Integer Dim yoko As String, tate As String Dim suuji (19) As String Sub 描画() Cells(X, Y).Value = suuji End Sub Sub 削除() Cells(X, Y).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() If yoko = "右" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 30 Then yoko = "左" ElseIf Y = 1 Then yoko = "右" End If If tate = "上" Then X = X + 1 Else X = X - 1 End If If X = 20 Then tate = "下" ElseIf X = 1 Then tate = "上" End If End Sub Sub main() suuji (0) = a suuji (1) = b suuji (2) = c suuji (3) = d suuji (4) = e suuji (5) = f suuji (6) = g suuji (7) = h suuji (8) = i suuji (9) = j suuji (10) = k suuji (11) = l suuji (12) = m suuji (13) = n suuji (14) = o suuji (15) = p suuji (16) = q suuji (17) = r suuji (18) = s suuji (19) = t For n = 0 To 19 Cells(X,Y).Value = suuji (n) Next X = 1 Y = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop 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 　　　　　　どこかが間違っている気がしますがマクロ初心者のため 　　　　　　先に進めません。 　　　　　　どうかご教授よろしくお願い致します。

  • Excelにおけるセルの値をVB2005に配列として取り込みたい

    Excelのセルの値をVB2005に配列として取り込みたいのですが、Excel.Rangeと配列の整合性が取れず困っています。 なんらかヒントになるような助言をお願いします。 以下は今までに作成中のコードです。 Public Class Form1 Dim xlsapp As New Excel.Application Dim xlsbook As Excel.Workbook Dim xlssheet As Excel.Worksheet Dim fn As String = "sample.xls" Dim Q(,,) As Double Dim i, j, x, y, z As Integer Dim k As Double Dim w(i), v(i), u(i) As Double Dim As Object Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click xlsbook = xlsapp.Workbooks.Open(fn) xlssheet = xlsbook.Worksheets(1) k = 1 w(i) = xlssheet.Cells(1, 3) v(i) = xlssheet.Cells(1, 2) u(i) = xlssheet.Cells(1, 1) For x = 2 To 11 If w(i) = 1 Then For y = 2 To 11 If v(i) = 1 Then Q(1, 1, k) = u(i) k = k + 1 End If Next End If Next z = k For k = 1 To z TextBox1.Text = Q(1, 1, k) Next End Sub Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click Me.Close() xlsapp.DisplayAlerts = False xlssheet = Nothing xlsbook.Close() xlsbook = Nothing xlsapp.Quit() xlsapp = Nothing End Sub End Class

  • VB IF なぜ構文エラーにならないのですか？

    Dim x, y, z As Integer x = 1 y = 1 z = 1 If x = y And y = z Then MessageBox.Show("OK") End If ３つの値が同じならアラートを出したいのです。このソースでできるかとおもいます。。。 しかし・・・・ If x = y = z Then MessageBox.Show("OK") End If とするとアラートが出ません。関数的に使い方が間違っているのでしょうか？　もしそうならなぜ構文エラーが出ないのでしょうか？ よろしくお願いします。 言語Microsoft Visual Basic 2008 Express Edition

  • エクセルで、こうやっても反応なしです。

    よろしくお願いします。以下のように組んで見ました。 Private Sub Worksheet_Change(ByVal Target As range) Dim clm As Integer Dim row As Integer clm = Target.Column row = Target.row If Worksheets("発注指示").Cells(row, clm) = "不足" Then MsgBox "在庫不足", vbOKOnly, "注意" End If End Sub どうして動かないのでしょう。 本当にわからないので、教えてください。 これで一日つぶれました。

  • macroについて教えてください

    こんにちは。以前こちらでPrivate SubについてMacroを教えていただきました。（あの後ログインパスワード等が不明になりお礼も出来ませんでしたが。。。回答頂いた方すみませんでした。） 下記がそのMacroですが、今回また少し変えることになり どのように変えていいのか分かりません。 前回は1～5はグレー、6～10は茶色・・・という形にしたのですが 今回は進捗率での管理をしたく、80％以下は白、80～90％は赤、90～100％は青としたいと思っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim iColors As Variant Dim rw As Long Dim CellCnt As Integer Dim col As Integer Dim col2 As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim c As Variant Dim ar() As Variant Dim Sh1 As Worksheet Set Sh1 = Worksheets("小児科Dr") col = Target.Cells(1).Column '制限された列 If Not (col = 4 Or col = 8 Or col = 12 Or col = 16) Then Exit Sub iColors = Array(16, 16, 16, 16, 16, 53, 53, 53, 53, 53, 54, 54, 54, 54, 54) CellCnt = Target.Count ReDim ar(CellCnt - 1) For Each c In Target If c.Value <> "" Then If IsNumeric(c.Value) Then i = c.Value If i >= 11 Then i = 10 End If If i > 0 And i < 11 Then j = iColors(i - 1) Else j = 2 End If ar(k) = j k = k + 1 End If End If Next c rw = Target.Row Select Case col Case 4: col2 = 2 Case 8: col2 = 8 Case 12: col2 = 14 Case 16: col2 = 20 'Sh1.Cells(rw + 2, 13).Resize(Int(Target.Count / 3), 3).Interior.ColorIndex = j End Select InsideColors Sh1, rw, col2, CellCnt, ar() Set Sh1 = Nothing End Sub Private Sub InsideColors(sh As Worksheet, _ rw As Long, _ col As Integer, _ cnt As Integer, _ ar As Variant) 'sh[シート],rw[行], col[列],cnt[セル個数],iColor[色指数] Dim i As Integer Dim j As Integer Dim n As Integer Dim k As Integer If cnt Mod 5 > 0 Then '範囲行数 i = (cnt + 5 - (cnt Mod 5)) / 5 Else i = cnt / 5 End If rw = Int((rw - 1) / 5) + 1 '行再設定 j = ((rw - 1) Mod 5) + 1 '列設定 For n = j To cnt sh.Cells(rw + 2, col).Resize(i, 5).Cells(n).Interior.ColorIndex = ar(k) k = k + 1 Next n End Sub 毎回他の人を頼ってしまい、申し訳ないのですがお願いします。 また、前回分からなかったので1～5を指定するときに5回同じカラー番号を書いたのですがこちらも良かったら手直し方法を教えていただければ助かります。 宜しくお願いします。

  • Excel　VBA　・・・教えてください

    何度も質問させて頂いてます。すみません、 下記のプログラムはこの場で教えて頂いたプログラムで、 実行すると●の後を▲や■が追いかける動きをします。 下記のプログラムをある程度使用して １～２０の数字が順々で追いかけっこする プログラムを作成するにはどのようにすればいいのでしょうか… できればプログラムは長めにならず ２０の数字から簡単に増やすことのできるような そんなプログラムが作成したいです… どなたかアドバイスお持ちの方 教えて下さいお願いします... Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub

  • ExcelのVBAについて

    ExcelのVBAを使って 縦20のセル、横30のセルの枠を作り 枠内で●が動き、枠に当たると跳ね返りの 繰り返しプログラムが作りたいんですが… プログラムはここまでできています↓ Sub 試作品() Dim hara As Integer, kyo As Integer Dim X As Integer, Y As Integer Dim V As String Dim hyouji As String hyouji = "●" 'hyoujiという変数に●を入れる X = 1 'Xに１を入れる Y = 1 V = "" V = "上" '------------------------------------------ Do Cells(X, Y).Value = hyouji 'XとYの位置にあるセルに●を表示 For hara = 0 To 10000 ' For kyo = 0 To 1000 'タイマーの役割 Next ' Next ' Cells(X, Y).Value = "" 'XとYの位置にあるセルに●を消す For hara = 0 To 10000 ' For kyo = 0 To 1000 'タイマーの役割 Next ' Next ' If V = "上" Then '上から来た●なら X = X + 1 'Xに１を足す Y = Y + 1 Else: V = "下" '下から来た●なら X = X - 1 'Xから１を引く Y = Y - 1 End If If X = 20 Then 'Xが20になったら V = "下" 'ループ外で定義した"上"を下に反転させる ElseIf X = 1 Then 'Xが１になったら V = "上" '下を上に反転 End If If Y = 30 Then V = "下" ElseIf Y = 1 Then V = "上" End If Loop '------------------------------------------ End Sub できたらこのプログラムに追加して 作成したいのですが… この際できれば嬉しいので これ以外のプログラムがあれば 教えて欲しいです。 VBA得意な方、お願いします;;

  • ExcelのVBAでブックを保存

    住所録Aと住所録Bがあります。 AとBを比較して、差異をを別ファイルに出力しようとしています。 比較元となるファイルは、AでもBでもかまいません。 比較、判定、ファイルへの出力部分は、省略していますが、保存 する場合は、どこに行うのがよいのですか bookですか。sheetですか。 両方で、SaveAsができまが、使い分けがあるのでしょうか。 どのように使い分けするのでしょうか。 書き方、使い方のおかしいところを指摘して頂くとありがたい です。 --------------------------------------------------------------------------------------------------- Option Explicit Sub test() Dim ret As Integer Dim row1 As Long Dim col1 As Long Dim row2 As Long Dim col2 As Long Dim myRtn As Boolean Dim fno1 As String Dim fno2 As String Dim OutBook As New Workbook Dim OutSheet As New Worksheet Dim OutFileName As String Dim cnt As Integer Dim I As Integer ret = MsgBox("処理を開始します。" + Chr(13) + Chr(10) + "よろしいですか。？", _ vbYesNo + vbQuestion) If ret = vbNo Then End End If myRtn = Application.Dialogs(xlDialogOpen).Show If myRtn = False Then MsgBox "［キャンセル］が選択されました" & vbCr & _ "処理を終了します" Exit Sub End If fno1 = Application.ActiveWorkbook.Name myRtn = Application.Dialogs(xlDialogOpen).Show If myRtn = False Then MsgBox "［キャンセル］が選択されました" & vbCr & _ "処理を終了します" Exit Sub End If fno2 = Application.ActiveWorkbook.Name Set OutBook = Workbooks.Add Set OutSheet = ActiveSheet OutBook.Worksheets(1).Name = "テスト" OutFileName = "テスト.xls" With Application.Workbooks(fno1).Worksheets(1) row1 = 1 col1 = 1 cnt = 1 Do While .Cells(row1, 1) <> "" 処理 （省略） Loop End With MsgBox "処理が終了しました。", vbOKOnly + vbInformation, "確認" Application.Workbooks(fno1).Close Application.Workbooks(fno2).Close OutSheet.SaveAs Filename:=OutFileName OutBook.SaveAs Filename:=OutFileName OutBook.Close End Sub --------------------------------------------------------------------------------------------------- OutSheet.SaveAs Filename:=OutFileName or OutBook.SaveAs Filename:=OutFileName のどちらでも保存ができます。 また、書き方、使い方のおかしいところを指摘して頂くとありがたいです。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する