[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『既存データを表にするには』（なお）
初めて投稿いたします。全文検索しましたが、しっくりくるものが分かりませんでした。
現在扱っているデータを所定の表にまとめたいのですが、思うように行かなくて困っています。
行の項目が多いので羅列して書きますと A1物件区分、B1物件番号、C1担当者、D1物件名称、E1所在地、F1物件種別、G1物件種目、H1用途地域、 I1土地面積（㎡）From、J1土地面積（㎡）To、K1土地面積（坪）From、L1土地面積（坪）To、 M1建物面積（㎡）From、N1建物面積（㎡）To、O1建物面積（坪）From、P1建物面積（坪）To、 Q1価格（万円）From、R1価格（万円）To、S1補足情報、T1受付日、U1媒介契約日、V1契約日、 W1商談状況、X1重要度、Y1成約ランク、Z1情報公開区分、AA1情報精度、AB1セキュリティ、 AC1情報入手先、AD1情報入手者、AE1駅名等、AF1バス、AG1徒歩 というように1行目には入力されており、2行目からは各データが該当の列に入力されています。（表1とします）
これを 表2 A B C D E F 1 物件番号 所在地 物件種別 土地面積(㎡) 建物面積(㎡) 価格 2 担当者 物件種目 土地面積(坪) 建物面積(坪) 3 補足情報
というような形の3行1物件での表を別シートに作成したいのです。
というのも、このデータをA3用紙にプリントアウトしなければならず、表1から不必要な項目を削除しても1行には収まらないためです。 また「所在地」や「補足情報」などは文字が大量に入力されている事があるため、表2の6列でもA3横がギリギリの状態です。
データ自体は別のシステムに入力をしていて、その中である条件を入れて検索した結果をCSV出力しています。 それをエクセルで開くと一番上のデータのように一覧で出てくる仕組みです。 エクセルを開いた時点から新たに人がシートにデータを入力する事はありません。
また上記表2のD1、E1、F1、D2、E2についてですが、D1には表1のI1・K1を参照して「I1～K1」のように表示したいのですが、 データごとに空白のセルもあるため、I列K列も空白のデータだった場合は空白にしたいのです。 同じように表２のE1にはM1・N1を、F1にはQ1・R1を、D2にはK1・L1を、E2にはO1・P1を入力していきたいのです。
検索条件によっては何千件と上がってきてしまうので、手作業には時間的にも限界があり困っています。
説明が上手くまとまってないと思いますが、どうかご教授よろしくお願い致します。 また、代替案などもありましたら是非お願い致します。
気合の入っていない数式で良ければ。。。 [[20100307204901]] 『カード作成』（km）
＞何千件と上がってきてしまうので って事なので、どうかなぁ。。。
(HANA)
HANA様
有難うございます。 早速参照させていただきました。完璧です！ タイトル行が3行ありますので、4～6行目の各セルに数式を入れたものを雛形として保存して、 データシートを雛形のブックにコピーして活用したいと思います。 有難うございました！！
あとは、もう一つの >また上記表2のD1、E1、F1、D2、E2についてですが、D1には表1のI1・K1を参照して「I1～K1」のように表示したいのですが、 >データごとに空白のセルもあるため、I列K列も空白のデータだった場合は空白にしたいのです。 >同じように表２のE1にはM1・N1を、F1にはQ1・R1を、D2にはK1・L1を、E2にはO1・P1を入力していきたいのです。 の部分についてなんですが、どうにかなりませんでしょうか。。。
現状ではデータシートにKの後ろに一列挿入して（後ろは1列づつずれていきます）新しいL列に＆を使って文字を連結しています。 同じようにFrom～Toの形で5項目とも1列追加して連結しました。 そして、この連結をした列を参照して表2を作成しました。 この場合（当然ですが）From列もTo列も空白だった場合、連結列には「～」と表示されています。 「空白にしたい」と書きましたが、抽出条件によって金額の指定がない場合は「相談」や「相場」などの文字を入れたいと考えています。 （もちろん空白のままという場合もあります）
表作成がかなりスムーズになったので、このあたりは手作業でもそんなに時間はかからないと思うのですが、なにかいい案等ありましたらご教授下さい。
（なお）
＞抽出条件によって金額の指定がない場合は「相談」や「相場」などの文字を入れたいと考えています。 これは、どの段階で決まる事なんですか？
それから ＞データシートにKの後ろに一列挿入して（後ろは1列づつずれていきます） これって、今後毎回この作業を行うつもり （或いは、データを貼り付けるときに 列をあけながら貼り付けるつもり） なのでしょうか？
＞I列K列も空白のデータだった場合は空白にしたいのです。 どちらか片方だけが空白でない場合 なんてパターンも有りますか？ でしたら =IF(I列="",""",I列)&IF(AND(I列="",K列=""),"","～")&IF(K列="","",K列) って感じにすると、どちらも空白の時は「～」が表示されなくなると思いますが。。。
事前に分かっている場合、「相談」や「相場」などを 例えば、AA列に入れるなら =IF(AA列="",I列&IF(AND(I列="",K列=""),"","～")&K列,AA列) って感じにしても良いと思います。
＞E1にはM1・N1を、F1にはQ1・R1を、D2にはK1・L1を、E2にはO1・P1を入力 I列K列を参照する場合も同じですが（表1の方に作業列を作らなくても） =INDEX(Sheet1!M:M,ROW(A4)/4)&INDEX(Sheet1!N:N,ROW(A4)/4) と言った感じで、くっつけて仕舞えば良いと思いますが。。。？ 勿論、表1の方で&でくっつけておいても良いと思いますし。。。 あ「括弧も要る。空白の場合も有る」って事かな？
なんか、こんな書き方で分かります？
(HANA)
HANAさんお邪魔します。
参考程度にＶＢＡで考えてみましたので載せてみます。 以下のコードで、元データのシートをアクティブにした状態で実行してください。 新規のシートを作成して表を整理します。
Sub Test()
Dim LRow As Long, i As Long, j As Long, CopyToAd As String
Application.ScreenUpdating = False
With ThisWorkbook
.ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
With .Sheets(.Sheets.Count)
.Range("A:A,D:D,H:H,T:AG").Delete Shift:=xlToLeft
.Rows(1).Delete Shift:=xlUp
LRow = .Cells.Find("*", .Cells(1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row
For i = 1 To LRow
For j = 6 To 15 Step 2
.Cells(i, j).Value = _
.Cells(i, j).Value & IIf(.Cells(i, j + 1).Value = "", "", "～" & .Cells(i, j + 1).Value)
Next j
Next i
.Range("G:G,I:I,K:K,M:M,O:O").Delete Shift:=xlToLeft
For i = LRow To 2 Step -1
.Rows(i).Resize(2).Insert Shift:=xlDown
Next i
For i = 2 To 11
.UsedRange.Columns(i).Copy
CopyToAd = Choose(i - 1, "A2", "B1", "C1", "C2", "D1", "D2", "E1", "E2", "F1", "A3")
.Range(CopyToAd).PasteSpecial xlPasteAll, xlNone, True, False
Next i
.Columns("G:K").Delete Shift:=xlToLeft
.Columns("A:F").AutoFit
.Range("A1").Select
End With
End With
Application.ScreenUpdating = True
End Sub
（ｍｏｍｏ）
度々有難うございます。
＞これは、どの段階で決まる事なんですか？ 抽出する段階で決まっています。
＞これって、今後毎回この作業を行うつもり はい。。。そのつもりでした（汗
＞どちらか片方だけが空白でない場合 なんてパターンも有りますか？ はい、あります。 両方とも入力されている方が珍しいくらいです。
私の一番最初の質問の段階から間違えていましたが、正しくはI列～J列ですね。。。 教えていただいた関数を入力してみましたが、 「入力した数式は正しくありません」とエラーが表示され、"～"の部分が黒に反転します。
＞=IF(AA列="",I列&IF(AND(I列="",K列=""),"","～")&K列,AA列) こちらの場合は 実際にはAM列に相場と入力しましたので =IF(AM:AM="",I:I&IF(AND(I:I="",J:J=""),"","～")&J:J,AM:AM) としましたところ、どの場合であってもAM列が反映してしまいます。
＞=INDEX(Sheet1!M:M,ROW(A4)/4)&INDEX(Sheet1!N:N,ROW(A4)/4) こちらは、上手く出来ました！ありがとうございます！ ＆しか使ってないように思うんですが、入力してみると「～」（半角ですが）が表示されるのには 何かルールがあるんでしょうか。
＞「括弧も要る。空白の場合も有る」 ここはイマイチ分かりませんでした。 申し訳ありませんがご説明いただけると助かります。
私のほうこそ説明が不十分ですみません。 引き続きよろしくお願い致します。
(なお）
えっと、、、普通の数式なので セル番地は適当に合わせて下さい。 （AA列のセル って書けば良かったかな？）
＞＞=IF(AA列="",I列&IF(AND(I列="",K列=""),"","～")&K列,AA列) =IF(AA1="",I1&IF(AND(I1="",K1=""),"","～")&K1,AA1)
＞=IF(AM:AM="",I:I&IF(AND(I:I="",J:J=""),"","～")&J:J,AM:AM) =IF(AM1="",I1&IF(AND(I1="",J1=""),"","～")&J1,AM1)
↑は、Sheet1の作業列に入れる用の式です。 で、その様に表示されるので良ければ AM1 とかの部分は INDEX(Sheet1!AM:AM,ROW(A4)/4) に変更して 表2の表で直接作って仕舞っても良いかもしれません。 式が長くなってしまいますが。
＞＆しか使ってないように思うんですが、入力してみると「～」（半角ですが）が表示されるのには ん？元の方（Sheet1のM列かN列）に「～」が入ってるんじゃないんですか？ ＆しか使ってないですから。
どこかに別々に値を返して確認してみられてはどうでしょう。 =INDEX(Sheet1!M:M,ROW(A4)/4) =INDEX(Sheet1!N:N,ROW(A4)/4) 単独では「～」は無いのに、＆でくっつけると、途端に「～」が出てきますか？
＞＞「括弧も要る。空白の場合も有る」 ＞ここはイマイチ分かりませんでした。 いや、 ＞＞=INDEX(Sheet1!M:M,ROW(A4)/4)&INDEX(Sheet1!N:N,ROW(A4)/4) で良かったんなら、良いです。 「土地面積(㎡)」←㎡の前と後ろに有る括弧や㎡の文字の事でした。
(HANA)
ｍｏｍｏ様
有難うございます。 早速試してみました。 元データのA列、B列、C列は新規シートのA列にそれぞれ上手く入りました。 またI列とJ列が同じ数字だった場合、～ではなくその数字のまま入力されていて 当初から諦めていた完全なカタチでした！
しかし、新規シートのF1には元データのI2が（1行目はタイトル行です）、 D4にはF3が、E4にはG3が。。。という風に少しづつずれてしまいます。 ずれている、というよりはブランクのセルに違うデータのセルが参照されているようなイメージです。
お教え頂いたVBAとデータをよく見て、明日またお返事させて頂きたいと思います。 よろしくお願い致します。
（なお）
私の方ではちゃんと最初の質問どおりになっているのですが・・・ 例：新規シートF1には元データのQ2とR2（価格)が入ります。
元データは数式かなにか使ってますか？（CSVとの事なので値だと思い込んでいますが） （ｍｏｍｏ）
ｍｏｍｏ様
昨日は中途半端なまま落ちてしまいすみませんでした。
今朝もう一度試してみましたが、やはり同じ現象でした。 状態としては、 元データの価格（Ｑ，Ｒ）が共に空白の場合→新規データＦ列には土地㎡（Ｉ，Ｊ）が 元データの土地㎡（Ｉ，Ｊ）が共に空白の場合→新規データＤ列には物件種別（Ｆ）が 元データの建物㎡（Ｍ，Ｎ）が共に空白の場合→新規データＥ列には物件種目（Ｇ）が 表示されています。
元データには数式は入っていません。
ｍｏｍｏ様の方ではちゃんと出来ているとのことですので、 私の方で何か問題があるとは思うのですが。。。
（なお）
なるほど、「両方空白」がありえるのですね。 そこは考慮してませんでした。
現象は確認できましたので、修正コードを以下に掲載します。 修正箇所は「★追加」の１行を追加したのみです。
Sub Test()
Dim LRow As Long, i As Long, j As Long, CopyToAd As String
Application.ScreenUpdating = False
With ThisWorkbook
.ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
With .Sheets(.Sheets.Count)
.Range("A:A,D:D,H:H,T:AG").Delete Shift:=xlToLeft
.Rows(1).Delete Shift:=xlUp
LRow = .Cells.Find("*", .Cells(1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row
For i = 1 To LRow
For j = 6 To 15 Step 2
.Cells(i, j).Value = _
.Cells(i, j).Value & IIf(.Cells(i, j + 1).Value = "", "", "～" & .Cells(i, j + 1).Value)
Next j
Next i
.Range("G:G,I:I,K:K,M:M,O:O").Delete Shift:=xlToLeft
For i = LRow To 2 Step -1
.Rows(i).Resize(2).Insert Shift:=xlDown
Next i
For i = 2 To 11
.UsedRange.Columns(i).Copy
CopyToAd = Choose(i - 1, "A2", "B1", "C1", "C2", "D1", "D2", "E1", "E2", "F1", "A3")
.Range(CopyToAd).PasteSpecial xlPasteAll, xlNone, True, False
.UsedRange.Columns(i).ClearContents '★追加
Next i
.Columns("G:K").Delete Shift:=xlToLeft
.Columns("A:F").AutoFit
.Range("A1").Select
End With
End With
Application.ScreenUpdating = True
End Sub
（ｍｏｍｏ）
HANA様
すみません、全然間違っていたんですね(汗
＞=IF(AM1="",I1&IF(AND(I1="",J1=""),"","～")&J1,AM1)
試してみました。 やはりAM列のみが反映されてしまいます。 まだ何か私が勘違いしているのでしょうか。。。
データのシートに新たにK列を作業列として挿入し、 AM列には全て「相場」と入力しています。 そして上記の式をK1に入力し、フィルドラッグでK列全てにコピーさせています。 もし作業的に間違いがありましたらご指摘下さい。
そして＆の式ですが、やはり私の勘違いでした。 そのままくっついています。 すみませんでした。
引き続きご教授よろしくお願い致します。
いいえ、紛らわしい書き方をして済みませんでした。
＞AM列には全て「相場」と入力しています。 そしたら、K列は「相場」と入りますよ。。。
IF関数で AM1=""－－－－－－－－－－－－－→AM1に何も入力が無いときに I1&IF(AND(I1="",J1=""),"","～")&J1 －－→I1とJ1を～で連結 それ以外（AM1に何か入力が有るとき）は AM1－－－－－－－－－－－－－－－－－－→AM1 の値を表示 と言う数式に成っているので。。。
I1,JIの両方に入力が無いときに AM1を表示するなら =IF(AND(I1="",J1=""),AM1,IF(I1=J1,I1,I1&"～"&J1)) に成ります。
AND(I1="",J1="") －－－－－－－－－－→両方入力が無いときに AM1－－－－－－－－－－－－－－－－→AM1 の値を表示 それ以外は IF(I1=J1,I1,I1&"～"&J1)－－－－－－→【この数式】の結果を表示
【この数式】はもう一つIF関数で I1=J1 －－－－－－－－－－－－－－－→両方の値が等しい時に I1－－－－－－－－－－－－－－－－→I1 の値を表示 それ以外は I1&"～"&J1－－－－－－－－－－－－→「～」でくっつけた結果を表示
(HANA)
ｍｏｍｏ様
私の説明不足でした。すみませんでした。。。 新しい方で、試してみましたら、バッチリできました！ 有難うございます！
ｍｏｍｏ様のコードを使った場合、雛形が存在するのではないので 表の細かな指定（タイトル行やフォントサイズや列幅、用紙指定等）も一緒に出来ればと 思うのですが、可能でしょうか。
自分でも色々調べて試してみるつもりですので（時間はかかると思いますが）、 お付き合いいただければと思います。
よろしくお願い致します。
（なお）
>表の細かな指定（タイトル行やフォントサイズや列幅、用紙指定等）も一緒に出来れば どのようにしたいのかによりますが コード内で設定も出来ますし 今の新規シートの出力結果を雛形のシートに値貼り付けする事でも可能です。 どちらにするかは運用次第なのですが、どちらでも可能ですよ。 （ｍｏｍｏ）
丁寧なご説明有難うございます。
＞=IF(AND(I1="",J1=""),AM1,IF(I1=J1,I1,I1&"～"&J1)) この関数に上で教えていただきました ＞INDEX(Sheet1!AM:AM,ROW(A4)/4) を代入して表2に直接作ってみました。
雛形に全て入っていれば、私以外の人が作業してもスムーズですよね。 有難うございました！
HANA様、ｍｏｍｏ様
素人の私にも分かるように丁寧にご説明いただき有難うございます。 お二方のやり方は両方とも活用させていただきたいと思っています。
度々で本当に申し訳ないのですが、私自身も全然気付かず、むしろ忘れていたのですが、
＞「空白にしたい」と書きましたが、抽出条件によって金額の指定がない場合は「相談」や「相場」などの文字を入れたいと考えています。 ＞（もちろん空白のままという場合もあります） 私自身が書き込んだ部分なのですが、 「土地面積」や「建物部分」については参照セルが両方とも空白の場合、表2の対応セルも空白 「金額」については参照セルが両方とも空白の場合、表2の対応セルに「相場」 となるようにしたいのです。
今更で申し訳ないのですが、よろしくお願い致します。
（なお）
本当にありがとうございました！ また何かありましたらよろしくお願い致します！ (なお）
ｍｏｍｏ様
＞今の新規シートの出力結果を雛形のシートに値貼り付けする事でも可能です。 これは都度手作業で、ということでしょうか。 雛形については説明していませんでしたが、所在地のセルと価格のセルはそれぞれ結合しています。 （1行目と2行目、4行目と5行目･･･といった感じです） また罫線も引いてありますが、検索結果によって件数が変動する為、タイトル行とあと3件分くらいしか引いてありません。 HANA様の数式を1件目に入力し、セルの結合をしていて、2件目以降は結合セルはありません。 現状は1件目をフィルドラッグで行を増やしていくので 結合セルも罫線も1行目と同じ形で増えていき問題ないのですが 値として手作業で雛形に貼り付けると、セルの結合や罫線も手作業になってしまうようなイメージなのですが。。。
なので出来ればコードに入れ込んで解決したいと思っています。 私の思い違いでしたらご指摘下さい。 よろしくお願い致します。
（なお）
結合はあまりお勧めしませんが、やり方としては 結合セルの無い雛形を用意します。 出来たデータを雛形シートに値のみ貼り付けします。 どうしても結合したいのであれば、その後に結合＋値の合成（改行挟み）を行います。
以上の作業はマクロのコードで全て可能です。
雛形がどういうものかがわかれば、出来たシートを整形するのも出来ますし。 たとえば、こんな感じ
Sub Test()
Dim LRow As Long, i As Long, j As Long, CopyToAd As String
Application.ScreenUpdating = False
With ThisWorkbook
.ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
With .Sheets(.Sheets.Count)
.Range("A:A,D:D,H:H,T:AG").Delete Shift:=xlToLeft
.Rows(1).Delete Shift:=xlUp
LRow = .Cells.Find("*", .Cells(1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row
For i = 1 To LRow
For j = 6 To 15 Step 2
.Cells(i, j).Value = _
.Cells(i, j).Value & IIf(.Cells(i, j + 1).Value = "", "", "～" & .Cells(i, j + 1).Value)
Next j
Next i
.Range("G:G,I:I,K:K,M:M,O:O").Delete Shift:=xlToLeft
For i = LRow To 2 Step -1
.Rows(i).Resize(2).Insert Shift:=xlDown
Next i
For i = 2 To 11
.UsedRange.Columns(i).Copy
CopyToAd = Choose(i - 1, "A2", "B1", "C1", "C2", "D1", "D2", "E1", "E2", "F1", "A3")
.Range(CopyToAd).PasteSpecial xlPasteAll, xlNone, True, False
.UsedRange.Columns(i).ClearContents '★追加
Next i
.Columns("G:K").Delete Shift:=xlToLeft
.Columns("A:F").AutoFit
'=========== ここから追加 ==============
For i = 1 To .UsedRange.Rows.Count Step 3
.Range("B" & i & ":B" & i + 1).Merge
.Range("F" & i & ":F" & i + 1).Merge
With .Range("A" & i & ":F" & i + 2)
.Borders.LineStyle = xlContinuous
For j = 7 To 10
.Borders(j).Weight = xlMedium
Next j
End With
Next i
.Rows(1).Insert Shift:=xlDown
With .Range("A1:F1")
.Merge
.Value = "タイトル"
.HorizontalAlignment = xlCenter
End With
'=========== ここまで ==================
.Range("A1").Select
End With
End With
Application.ScreenUpdating = True
End Sub
（ｍｏｍｏ）
ｍｏｍｏ様
有難うございます！ 早速実行してみましたら、希望に近い形になっていました！
雛形は、タイトル行も3行で A B C D E F ――――――――――――――――――――――――――――――――――――――――――― 1 ｜ 物件番号 : : 物件種別 : 土地面積(㎡) : 建物面積(㎡) : ｜ ｜･････････････ 所在地 ････････････････････････････････････････････････ 価格（万円）｜ 2 ｜ 担当者 : : 物件種目 : 土地面積(坪) : 建物面積(坪) : ｜ ｜･････････････････････････････････････････････････････････････････････････････････････｜ 3 ｜ 補足情報 ｜ ―――――――――――――――――――――――――――――――――――――――――――
というような形で、罫線は外枠と3行毎の区切りは実線、 内側は一番細かい点線（プリントアウトすると薄い実線になる）で補足情報の行は縦の罫線はありません。 （文字が入ります） 上記の表で伝わりますでしょうか。。。
更に、 ・フォントサイズは９ ・タイトル行のセルの色は黄色（36） ・列の幅は、Ａ=11、Ｂ=111、Ｃ=14、Ｄ～Ｆ=18 ・行の幅は全て15 ・用紙サイズはＢ４（当初Ａ３の予定でしたが、状況によって印刷時拡大する方向で考えています） ・余白は上1.5、下1、右2、左2、ヘッダー0.8、フッター0.5 ・印刷タイトルの行のタイトルは1行目から3行目
といった形を雛形としたいのです。
私自身でも初心者ながらマクロの自動記録でコードを調べたりはしてみましたが、 ｍｏｍｏ様のコードを理解する事でいっぱいいっぱいになってしまって、 どこにどう入れ込んでいけばいいのかがわからず。。。
次から次へと希望を出してしまい、当初の質問と少しずれてしまったかもしれません（汗 申し訳ありませんが、ご教授いただければと思います。
（なお）
マクロ記録を整形する方法を覚えて、それからヘルプなどで調べるとVBAが楽しくなりますよ^^
たぶんこれで出来ると思いますので、じっくりコードを読んでなおさんの身になれば。と思います。 頑張ってください。
なお、PageSetupはExcelの特性上多少時間が掛かりますので コードの実行完了までが長く感じるかもしれません。
Sub Test()
Dim LRow As Long, i As Long, j As Long, CopyToAd As String
Application.ScreenUpdating = False
With ThisWorkbook
.ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
With .Sheets(.Sheets.Count)
.Range("A:A,D:D,H:H,T:AG").Delete Shift:=xlToLeft
.Rows(1).Delete Shift:=xlUp
LRow = .Cells.Find("*", .Cells(1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row
For i = 1 To LRow
For j = 6 To 15 Step 2
.Cells(i, j).Value = _
.Cells(i, j).Value & IIf(.Cells(i, j + 1).Value = "", "", "～" & .Cells(i, j + 1).Value)
Next j
Next i
.Range("G:G,I:I,K:K,M:M,O:O").Delete Shift:=xlToLeft
.Rows(1).Insert Shift:=xlDown
With .Range("A1:K1")
.Value = Array("物件番号", "担当者", "所在地", "物件種別", "物件種目", "土地面積(㎡)", _
"土地面積(坪)", "建物面積(㎡)", "建物面積(坪)", "価格（万円）", "補足情報")
.Interior.ColorIndex = 36
End With
For i = LRow + 1 To 2 Step -1
.Rows(i).Resize(2).Insert Shift:=xlDown
Next i
For i = 2 To 11
.UsedRange.Columns(i).Copy
CopyToAd = Choose(i - 1, "A2", "B1", "C1", "C2", "D1", "D2", "E1", "E2", "F1", "A3")
.Range(CopyToAd).PasteSpecial xlPasteAll, xlNone, True, False
.UsedRange.Columns(i).ClearContents
Next i
.Columns("G:K").Delete Shift:=xlToLeft
For i = 1 To .UsedRange.Rows.Count Step 3
.Range("B" & i & ":B" & i + 1).Merge
.Range("F" & i & ":F" & i + 1).Merge
With .Range("A" & i & ":F" & i + 1).Borders
.LineStyle = xlContinuous
.Weight = xlHairline
End With
For j = 7 To 10
With .Range("A" & i & ":F" & i + 2).Borders(j)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next j
Next i
For i = 1 To 6
.Columns(i).ColumnWidth = Choose(i, 11, 111, 14, 18, 18, 18)
Next i
.UsedRange.EntireRow.RowHeight = 15
With .PageSetup
.PrintTitleRows = "$1:$3"
.LeftMargin = Application.CentimetersToPoints(2)
.RightMargin = Application.CentimetersToPoints(2)
.TopMargin = Application.CentimetersToPoints(1.5)
.BottomMargin = Application.CentimetersToPoints(1)
.HeaderMargin = Application.CentimetersToPoints(0.8)
.FooterMargin = Application.CentimetersToPoints(0.5)
.Orientation = xlLandscape
.PaperSize = xlPaperB4
End With
.Range("A1").Select
End With
End With
Application.ScreenUpdating = True
End Sub
（ｍｏｍｏ）
ｍｏｍｏ様
早速実行してみました！ありがとうございます。
フォントサイズの指定がなかったのですが、用紙サイズをＡ３にしましたら
綺麗に収まったのでＢ４をＡ３に変更して使いたいと思います。
ちなみに、フォントサイズを９にするとしたらどこに入れればいいか教えていただけると勉強になります。
自分でマクロ記録をして、PageSetupの次に貼り付けてみたんですが
新規シートのサイズは変わらず、元データのサイズが変わってしまいました。
With Cells.Font
.Name = "ＭＳ Ｐゴシック"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
それと、毎回毎回申し訳ないのですが、もう一つ。。。
補足情報には文字がたくさん入っていて、セルによって「折り返して全体を表示する」になっているのです。 これは元々のシステムに補足情報を登録する段階で、補足情報の指定欄でエンターキーで改行をしたり、 補足情報の欄の幅によって自動改行（っていうのか分かりませんが。。。）によって 複数行に渡っている場合に折り返しになっています。 これは元データを開いたときに既になっています。 当初この表示になっているものについては、文字数が多く枠内には1行で収まらず、 且つコメント自体不要な物が多い場合が多数であったため、 作業者が手作業で不要コメント削除しながら書式設定を変えればいいかな。と思っていました。 しかし、場合によっては、例えば 「探索中 ｍｏｍｏ様へ資料送付 返答待ち」 のようにシステムでの入力者が任意で改行していた場合、折り返さなければ問題なく枠内に収まるものもあります。 更に、ほぼ全行に文字が入っている表なので、折り返しされているセルを見落とす可能性も考えられるので 「折り返して全体を表示」を解除して、外枠からはみ出しているものを編集した方が確実なのかな、と思い また自分で自動記録をしてみました。
Columns("A:A").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
これの先頭の部分を With Columns(1)として先程と同じようにPageSetupの次に貼り付けてみたんですが、解除されません。 試しにマクロで実行してみましたら、問題なく解除されました。
何度も何度も申し訳ないのですが、よろしくお願い致します。
（なお）
Withステートメントのフォーカスにさえ気をつければ、 必ずなおさんでも出来るようになります。 ふぁいとっ♪
> .UsedRange.EntireRow.RowHeight = 15
この１行を
With .UsedRange '★変更
.Font.Size = 9 '★変更
.EntireRow.RowHeight = 15 '★変更
.Columns("A").WrapText = False '★変更
End With '★変更
の5行に変更してみてください。 （ｍｏｍｏ）
ｍｏｍｏ様
有難うございます！！ これで完璧に出来ました！
この場合に限らず、システム上のデータを出力したものを参照して資料を作成することが多いので このコードを勉強して応用させていきたいと思います。
最後までお付き合い下さって本当に有難うございました！
（なお）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.