[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『名簿から条件分けして別シートの枠内へ振り分ける』（少年野球の運営は大変）
初めて投稿させて頂きます。宜しくお願い致します。
簡単に要点を説明しますと、寄付金を集めて、一定額に応じて３段階の広告掲示をした小冊子を製作するのが目的です。
例：１万円の寄付者は、Ａ４用紙２分の１の大きさ枠へ。３千円は、４分の１へ。
現状は、寄付者のリストを見ながら、手入力で枠へ入力しています。
やりたい事は
リストから金額の条件振りをし、１万円以上、１万円未満〜５千円以上、５千円未満の３枠に自動で振り分けをする。
枠のフォーマットはあるので、各々へ自動入力される。
人数は、毎回違うので、人数に応じてページは自動で増える。
以上の様な仕様になります。
やれるであろう事はなんとなく分かるのですが、何をどうやってまでは全くわかりません。関数、マクロ、ＶＢＡ共に、知識は殆どありません。一通り触ってはいますが、簡単なレクチャーを数年前に受けただけで、実務でも使ってはいません。
有識者の方のご助力を頂けると助かります。
どうぞ宜しくお願い致します。
追記：エクセルのバージョンは2013ですが、他の方へ受け継いで行く物なので、出来れば2010位から使えると融通がきくかと思います。出来ればですが。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
こんばんわ。
どのシートのどのセルに寄付金の金額や氏名、その他必要事項が入ってるんですか？ 結果のシートは別？ 結果を何処にどのように表示させたいんですか？
元シートのレイアウトと、結果のイメージのレイアウトを提示して下さい。
（sy） 2016/08/31(水) 22:31
おはようございます。
コメントありがとうございます。
現在手元にデータがなく、私もデータはまだ見たことがないので分からないのですが（９月１８日までに仕上げたいので、先走って投稿しました）、シートなどは、自分で都合よく作れると思います。今までの形式にとらわれる必要はないので（主婦が適当に作ったやつらしいので）。
私のイメージだと、シート１に名簿リスト（名前、連絡先＜空欄の場合もあり＞、金額程度の情報量）
シート２にＡ４ページに２枠用の大広告ページ（１万円以上者）
シート３にＡ４ページに４枠用の中広告ページ（５千円以上者）
シート４にＡ４ページに８枠用の小広告ページ（３千円以上者）
枠のスタイルは、
┌───┐ ┌───┐ すみません
│ │ ├───┤ ８枠は書くの大変
├───┤ ├───┤ なので省略します
│ │ ├───┤
└───┘ └───┘ 単純に４枠の倍です
この様な枠になります。
入力される文字は、それぞれ中央中央ぞろえで、枠にあった大きさでの表示です。
以上の情報で足りるでしょうか？
宜しくお願い致します。
（少年野球の運営は大変） 2016/09/01(木) 09:15
データ入手しましたので、詳細を明示します。
現状、名簿シートに、会社名、氏名（未記入あり）、郵便番号、住所、電話番号（未記入あり）、備考となります。
金額別に表になっており、上から、２万円、１万円、５千円、３千円、個人です。
まず、各枠の配置ですが
（株）○○○○商事（３〜１２文字位）←会社名
代表取締役○○○○ ←氏名（未記入あり）
〒***-**** ←郵便番号
○○県○○市○○1234 ←住所
Tel 0123-456-789 ←電場番号（未記入あり）
以上の順になります。
次にフォントサイズですが
１万円枠：会社名４８、氏名１８、郵便番号１８、住所１８、電話番号１４
５千円枠：会社名３６、氏名１８、郵便番号１８、住所１８、電話番号１４
３千円枠：会社名３６、氏名（氏名欄なし）、郵便番号１４、住所１４、電話番号１２
個人：名前のみで、フォントサイズ２２
次にページにおける配置ですが
Ａ４ページに区切りの線などはなく、枠のみです。置き方は、前の投稿どおり上から１列ずつになります。
１万円枠：２枠
５千円枠：４枠
３千円枠：５枠
個人枠：名前、名前と同等のスペース、名前の順で入るだけ
概ね以上となりますが、ご不明点がありましたら、ご指摘お願い致します。
念の為に補足をさせて頂きますと
寄付金と書いてしまいましたが、当チーム主催の大会を運営する為の、協賛金という名目になります。
（少年野球の運営は大変） 2016/09/01(木) 10:33
「枠」と呼んでいるものを、セルの連結で表現するとします。3種類の枠は、例えば 4x8,2x4,2x2 のセル（実際にはもっと大きい範囲でしょう）をそれぞれ連結したものを配置。また、全体にフォントを小さくして、1シートにレイアウトする数を増やし、必ずしも大きい枠が左ではなく、大中小が入り乱れた感じにレイアウトしておくと、広告っぽい感じになるように思いますよ。
この前提で、それぞれの枠のセル範囲をイミディエイトウィンドウに列挙するコード例を書いてみます。
実際には「:」より前だけ取り出し、ここに文字列を代入していく形になると思います。
Sub test()
Dim AR1 As Object
Dim AR2 As Object
Dim AR3 As Object
Dim R As Range
Dim i As Long
Set AR1 = CreateObject("System.Collections.ArrayList")
Set AR2 = CreateObject("System.Collections.ArrayList")
Set AR3 = CreateObject("System.Collections.ArrayList")
For Each R In Range("A1", Cells.SpecialCells(xlCellTypeLastCell))
If R.MergeCells = True Then
Select Case R.MergeArea.Count
Case 32
If Not AR1.Contains(R.MergeArea.Address) Then
AR1.Add R.MergeArea.Address
End If
Case 8
If Not AR2.Contains(R.MergeArea.Address) Then
AR2.Add R.MergeArea.Address
End If
Case 4
If Not AR3.Contains(R.MergeArea.Address) Then
AR3.Add R.MergeArea.Address
End If
End Select
End If
Next R
For i = 0 To AR1.Count - 1
Debug.Print AR1(i) & " ";
Next i
Debug.Print
For i = 0 To AR2.Count - 1
Debug.Print AR2(i) & " ";
Next i
Debug.Print
For i = 0 To AR3.Count - 1
Debug.Print AR3(i) & " ";
Next i
Debug.Print
End Sub
セルのレイアウト状況が配列に格納されていますので、後は金額毎に3種類に判定し、配列に格納されたアドレスのセルに代入していけば良いでしょう。
工夫しなければいけないのは、1シートに収まらなければ次のシート、という点。必要なシート数は、配列それぞれの個数と、データ数を比較すれば求められるかと思います。
（???） 2016/09/01(木) 11:00
ご教示ありがとうございます。
枠の正確な大きさをお伝えします。
1万円枠：９列×２４行で１枠（必要な部分のみ、結合して配置してあります）
２枠を１ページにバランスよく上下に配置
５千円枠：９列×１２行で１枠
４枠で１ページ
３千円枠：９列×９行で１枠
５枠で１ページ
個人枠：８列×２行で１枠
１４枠で１ページ（枠の間を調整し、人数により変化）
ご提案頂いている配置の件ですが、個人的にはありなんですが、責任者の同意が得られるかは微妙です。
出来れば、従来通りに若いページから順に、額の大きな掲示を割り当てたいと思います。
そして、一番の問題なのですが、上記プログラムをどのように使うのかも分かりません。
以前講義を受けた際の、よくわかるExcel 2010 マクロ/VBA FOMA出版の教本を出して来て
開発タブの出し方から始めてます。
もし可能でしたら、一連の流れ的なもののご教示も頂けると非常にありがたいのですが・・・
初心者過ぎて申し訳ありませんが、恥を忍んで書き込みをさせて頂いてます。
面倒かとは思いますが、許せる範囲で１からのご教示をお願い致します。
（少年野球の運営は大変） 2016/09/01(木) 14:12
とりあえず、もうすこし詳しいところを教えてください。
・「名簿」シートによると、2万、1万、5千、3千、個人と5段階あるようですが、レイアウトは4種？（1万と2万は同じ？）
・個人で1万払っても、レイアウトは個人のものですね？
・個人の場合は、会社欄が空欄と考えて良い？
・現状の「名簿」シートはデータが5つの表に分かれているようですが、これを「金額」の列を追加した、1つの表に変えても良い？（手作業のコピペを想定） 更には、マクロでソートして、並び替えても良い？
・ソートのため、「金額」列には、数値が入っている事が望ましいです。（手作業でソートしても高い順に並ぶよう）
・出力シートは金額毎に1ページずつレイアウトがあり、4シートあるということ？ それとも、1つの出力シートで、セル結合の範囲を変えつつ、全ページ分？
一例ですが、コーディングの考え方、処理の順番は、以下の感じでしょう。
・「名簿」をソートし、同じ金額のデータが連続するようにする。（今後の運用を考えると、表の一番下に追記するだろうから）
・「名簿」から、金額毎のデータ数を計算。（金額毎の先頭行も計算しておく）
・新規シート追加、またはひな形のシートをコピー。（印刷設定を引き継ぐなら、コピーが良いか）
・金額毎のデータ数分、セルを連結。ページの区切りには改行コードを埋めていく。
・「名簿」の先頭から順に、該当する金額の連結セルに文字列を代入していく。
・文字列の長さを計算。元データ別に、それぞれフォントサイズを変更。（ここだけでも、結構面倒）
（???） 2016/09/01(木) 16:08
ご面倒をおかけします。ご対応を頂き、本当に感謝します。
プログラミングは、大昔に授業にて基礎は学んでいて（BASICですが・・・）、仕事でも、ジャンルは違いますが、機械の制御をプログラムにて行っています。自意識過剰とは思いますが、ある程度作られた物であれば、カスタマイズは多少出来るかなと思い、やってみようと決断した次第です。
勿論、認識が甘いのは承知しています。中学校程度の英語力で、フランスで生活しようとしてるチャレンジ感だと分析しました（汗
質問にお答えします。
上から順に
・レイアウトは５種ですが、２万円に対しては件数が２件程度なので、直接配置をします。
従って、１万〜個人の４レイアウトを対象として下さい。
・個人は、金額の大小関係なく、個人のレイアウトになります。
・個人の場合、現状では名前以外は空欄になっています。というより、名簿にすらなっていません。
同一名簿上に私の独断で、個人を付け足しました。氏名の欄のみの入力になる可能性が大です。
・現状は、名簿の表となる物の上に、金額の見出し？があります。
２万円
だれだれ
だれだれ
１万円
だれだれ
だれだれ
といった感じです。
勿論、やり易いように、作り変えて頂いて構いません。その表を元に、出力用の表を作る事は可能でしょうから。
・金額欄には、必ず数値を入れるルールにします。
・出力シートは、現状、各金額毎にあります。２万（これは除外して可）、一万、五千、三千、個人、です。
＞・文字列の長さを計算。元データ別に、それぞれフォントサイズを変更。（ここだけでも、結構面倒）
この部分ですが、文字のフォントサイズは、前の投稿にあるサイズで固定し、文字数も最長文字数が入るセルで固定し、単純に代入される仕組みで構いません。
規格外になってしまう場合などは、手作業で帳尻をあわせます。
１００％で対応出来るのは理想ですが、そこまで贅沢は言いませんので。
お陰様で、作業の流れはなんとなくイメージがつきました。
勿論、自力では進めませんが。。。
引き続き、ご指南を頂ければと思います。
宜しくお願い致します。
（少年野球の運営は大変） 2016/09/01(木) 17:10
A B C D E F G 1 金額 会社名 氏名 郵便番号 住所 電話番号 備考 2 10000 3 5000
「名簿」シートに、ActiveXのボタンを1つ貼ってください。
「名簿」シートの後ろに、4つシートを用意し、それぞれ「10000」「5000」「3000」「個人」という名前にしてください。
追加した4つのシートは、セル幅や高さを調整し、1ページに収まるようにしてください。（後からでOK）
Private Sub CommandButton1_Click()
Dim cw As String
Dim i As Long
Dim j As Long
Dim iw As Long
Dim iDim(3, 2) As Long '行数、列数、件数
Dim iR(3) As Long
iDim(0, 0) = 24: iDim(0, 1) = 9
iDim(1, 0) = 12: iDim(1, 1) = 9
iDim(2, 0) = 9: iDim(2, 1) = 9
iDim(3, 0) = 2: iDim(3, 1) = 8
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
iw = fPat(Cells(i, "A"))
iDim(iw, 2) = iDim(iw, 2) + 1
Next i
For i = 0 To 3
With Sheets(i + 2)
.Cells.Delete
For j = 1 To iDim(i, 2)
With .Range(.Cells((j - 1) * iDim(i, 0) + 1, 1), .Cells(j * iDim(i, 0), iDim(i, 1)))
.MergeCells = True
.Borders.LineStyle = xlContinuous
End With
Next j
End With
Next i
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
iw = fPat(Cells(i, "A"))
cw = Cells(i, "B").Value & vbLf & _
Cells(i, "C").Value & vbLf & _
Cells(i, "D").Value & vbLf & _
Cells(i, "E").Value & vbLf & _
Cells(i, "F").Value
With Sheets(2 + iw)
.Cells(iR(iw) + 1, "A").Value = cw
End With
iR(iw) = iR(iw) + iDim(iw, 0)
Next i
End Sub
Function fPat(R As Range) As Long
If R.Offset(0, 1).Value = "" Then
fPat = 3
Else
Select Case R.Value
Case 10000 To 19999
fPat = 0
Case 5000 To 9999
fPat = 1
Case 3000 To 4999
fPat = 2
Case Else
fPat = 3
End Select
End If
End Function
まずはこのコードを動かせるか。動かしてみて、希望通りの動作かを教えてください。
（フォントサイズ変更部分は、今後時間が取れたら書いてみます）
（???） 2016/09/01(木) 18:57
迅速な対応ありがとうございます。
２時間位かかりましたが、希望通りの動作を確認出来ました！
後は、文字の大きさや配置、枠のあり方など、微調整だけかと思われます。
明日は１日出張でＰＣを触る事が無く、明後日は、１日子供達の野球の大会になるので、日曜にじっくり解析させて貰いたいと思います。
またご相談させて頂くかと思いますが、お時間の余裕がありましたらご助力をお願い出来ればと思います。
取り合えずですが、お力添えを頂き、ありがとうございました。
（少年野球の運営は大変） 2016/09/01(木) 21:00
Private Sub CommandButton1_Click()
Dim cw As String
Dim i As Long
Dim j As Long
Dim iw As Long
Dim iR(3) As Long
Dim iDim(3, 3) As Long '行数、列数、件数、改頁数
Dim iSize(3, 4) As Long
Dim iData(4, 1) As Long '文字数、位置
Dim cData(4) As String
iDim(0, 0) = 24: iDim(0, 1) = 9: iDim(0, 3) = 2
iDim(1, 0) = 12: iDim(1, 1) = 9: iDim(1, 3) = 4
iDim(2, 0) = 9: iDim(2, 1) = 9: iDim(2, 3) = 5
iDim(3, 0) = 2: iDim(3, 1) = 8: iDim(3, 3) = 14
iSize(0, 0) = 48: iSize(0, 1) = 18: iSize(0, 2) = 18: iSize(0, 3) = 18: iSize(0, 4) = 14
iSize(1, 0) = 36: iSize(1, 1) = 18: iSize(1, 2) = 18: iSize(1, 3) = 18: iSize(1, 4) = 14
iSize(2, 0) = 36: iSize(2, 1) = 18: iSize(2, 2) = 18: iSize(2, 3) = 18: iSize(2, 4) = 14
iSize(3, 0) = 22: iSize(3, 1) = 22: iSize(3, 2) = 18: iSize(3, 3) = 18: iSize(3, 4) = 14
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
iw = fPat(Cells(i, "A"))
iDim(iw, 2) = iDim(iw, 2) + 1
Next i
For i = 0 To 3
With Sheets(i + 2)
.Cells.Delete
.Cells.RowHeight = 800 / iDim(i, 0) / iDim(i, 3)
.Cells.ColumnWidth = 100 / iDim(i, 1)
For j = 1 To iDim(i, 2)
With .Range(.Cells((j - 1) * iDim(i, 0) + 1, 1), .Cells(j * iDim(i, 0), iDim(i, 1)))
.MergeCells = True
.Borders.LineStyle = xlContinuous
End With
If j Mod iDim(i, 3) = 0 Then
.HPageBreaks.Add Before:=.Rows(j * iDim(i, 0) + 1)
End If
Next j
End With
Next i
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
iw = fPat(Cells(i, "A"))
For j = 0 To 4
cData(j) = Trim(Cells(i, j + 2).Value)
iData(j, 0) = Len(cData(j))
If j = 0 Then
iData(j, 1) = 1
Else
iData(j, 1) = iData(j - 1, 0) + iData(j - 1, 1)
End If
Next j
With Sheets(2 + iw).Cells(iR(iw) + 1, "A")
If iw = 3 Then
.Value = cData(1)
.Font.Size = iSize(iw, 1)
ElseIf iw = 2 Then
.Value = Join(cData, vbLf)
.Value = Replace(.Value, vbLf & vbLf, vbLf)
.Characters(Start:=iData(0, 1), Length:=iData(0, 0)).Font.Size = iSize(iw, 0)
.Characters(Start:=iData(2, 1) + 1, Length:=iData(2, 0)).Font.Size = iSize(iw, 2)
.Characters(Start:=iData(3, 1) + 2, Length:=iData(3, 0)).Font.Size = iSize(iw, 3)
.Characters(Start:=iData(4, 1) + 3, Length:=iData(4, 0)).Font.Size = iSize(iw, 4)
Else
.Value = Join(cData, vbLf)
For j = 0 To 4
.Characters(Start:=iData(j, 1) + j, Length:=iData(j, 0)).Font.Size = iSize(iw, j)
Next j
End If
End With
iR(iw) = iR(iw) + iDim(iw, 0)
Next i
End Sub
（???） 2016/09/02(金) 15:43
上記フォント対応の動作確認出来ました。
本当にありがとうございました。
最終仕上がりまでは、まだ何かと修正をしなければなりませんが、あと１０日位の猶予があるので、勉強しながら自力でカスタマイズしてみます！
行き詰ったら、またこちらでご相談させて頂きますので、その際には、お力添えを頂ければ助かります。
本当にありがとうございました。助かりました。
では、失礼します。
（少年野球の運営は大変） 2016/09/04(日) 18:15
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.