Ｐａｇｅ 630 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼表の作成について ぷち 03/1/26(日) 1:56 ┗Re:表の作成について Hirofumi 03/1/26(日) 9:21 ┗Re:表の作成について Hirofumi 03/1/26(日) 9:41 ┗Re:表の作成について ぷち 03/1/28(火) 19:17 ─────────────────────────────────────── ■題名 ： 表の作成について ■名前 ： ぷち ■日付 ： 03/1/26(日) 1:56 -------------------------------------------------------------------------
| はじめまして。 皆さんこんばんは。 早速ですが表の作成について質問です。 sheet1に A列（商品名）B列（金額） １行 たまご 180 ２行 白菜 200 ３行 にんじん 180 ４行 こんにゃく 220 ５行 ごぼう 100 ６行 れたす 700 と言う表に新たに、 ７行 たくわん 300 という新しい行を加えた後に Sheet2へ A列 B列 C列 D列 E列 F列 G列 H列 １行 ごぼう 100 たくわん 300 にんじん 180 れたす 700 ２行 こんにゃく 220 たまご 180 白菜 200 と、あいうえお順でソート済みにしたSheet1を 左から順に４分割ぐらいの表をコマンドボタン等で 一発で作成させたいのですが…。 ※商品がSheet1に追加されても常に実行すると ４分割ぐらいで表示させたいんです（Sheet1が１００行ならば、Sheet2は２５行など） ※A列は常に文字列です 分りずらい文章で申し訳ありませんが、ＶＢＡで作成する ヒントだけでもかまいませんので 何卒ご教授のほど宜しくお願いいたします。 |
| UserFormで作るとこんな形かな？ 条件として 1、データのリストには列見出しが有ります 2、ソートをしていますが、質問の例では白菜が漢字で、 他がひらがななので、例のようには並びません もし、例の様に並べるならソートキーの列が必要です まずUserFormを追加して以下のコントロールを配置して下さい TextBox1 TextBox2 CommandButton1 以下のコードをUserFormのモジュールに記入してください Option Explicit Private lngListTop As Long Private lngListEnd As Long Private wksData As Worksheet Private wksResult As Worksheet Private Sub UserForm_Initialize() Set wksData = Worksheets("Sheet1") Set wksResult = Worksheets("Sheet2") With wksData 'Listの先頭（列見出し）位置 lngListTop = 1 'Listの最終（データ）位置 lngListEnd = .Cells(65536, 1).End(xlUp).Row If lngListEnd <= lngListTop Then lngListEnd = lngListTop + 1 End If End With End Sub Private Sub UserForm_Terminate() Set wksData = Nothing Set wksResult = Nothing End Sub Private Sub CommandButton1_Click() Dim i As Long Dim lngRow As Long Dim lngCol As Long Dim vntData As Variant Dim lngDataMax As Long Dim lngWRow As Long Dim lngWCol As Long If TextBox1.Text = "" Then Exit Sub End If lngListEnd = lngListEnd + 1 With wksData .Cells(lngListEnd, 1).Value = TextBox1.Text .Cells(lngListEnd, 2).Value = Val(TextBox2.Text) vntData = Range(.Cells(lngListTop + 1, 1), _ .Cells(lngListEnd, 2)).Value lngDataMax = UBound(vntData, 1) For i = 1 To lngDataMax vntData(i, 2) = lngListTop + i Next i End With 'データ配列のソート ShellSortExcel vntData '書き込み行数 lngRow = -Int(-lngDataMax / 4) '書き込み列数 lngCol = -Int(-lngDataMax / lngRow) With wksResult 'Sheet2の書き込み範囲の削除 .Range(.Cells(1, 1), .Cells(lngRow, lngCol)).Clear End With 'Sheet2へ書き込み With wksData For i = 0 To lngDataMax - 1 lngWRow = (i Mod lngRow + 1) lngWCol = ((i \ lngRow) Mod lngCol) * 2 + 1 .Range(.Cells(vntData(i + 1, 2), 1), _ .Cells(vntData(i + 1, 2), 2)).Copy _ Destination:=wksResult.Cells(lngWRow, lngWCol) Next i End With End Sub 以下のコードを標準モジュールに記入して下さい Option Explicit Option Compare Text '-------------------------------------------------------- ' ' シェルソート ' '-------------------------------------------------------- Public Sub ShellSortExcel(vntList As Variant, _ Optional lngNum As Long = -1, _ Optional lngStart As Long = -1) 'vntList :ソートする配列 'lngNum :ソート行数 'lngStart:ソート開始位置 Dim i As Long Dim j As Long Dim lngGap As Long Dim vntTmp(1) As Variant Dim lngTop As Long Dim lngEnd As Long lngTop = LBound(vntList, 1) If lngStart > -1 Then If lngStart >= LBound(vntList, 1) Then lngTop = lngStart End If End If lngEnd = UBound(vntList, 1) If lngNum > -1 Then If lngTop + lngNum - 1 <= UBound(vntList, 1) Then lngEnd = lngTop + lngNum - 1 End If End If lngGap = 1 Do While lngGap < (lngEnd - lngTop + 1) \ 3 lngGap = 3 * lngGap + 1 Loop Do Until lngGap <= 0 For i = lngGap + lngTop To lngEnd vntTmp(0) = vntList(i, 1) vntTmp(1) = vntList(i, 2) For j = i To lngGap + lngTop Step -lngGap If vntList(j - lngGap, 1) <= vntTmp(0) Then Exit For End If vntList(j, 1) = vntList(j - lngGap, 1) vntList(j, 2) = vntList(j - lngGap, 2) Next j vntList(j, 1) = vntTmp(0) vntList(j, 2) = vntTmp(1) Next i lngGap = lngGap \ 3 Loop End Sub |
| Sheet2の書き込み範囲の削除が、本当に書き込み範囲だけ削除してますから 以下の様にした方が良かったかも知れ無い 'Sheet2の書き込み範囲の削除 .Rows("1:" & .Cells(65536, 1).End(xlUp).Row).Delete |
| ▼Hirofumi さん： 返事が遅くなってすみません。 大変助かりました。 今後とも宜しくお願いいたします。 自分も勉強しますんで… |