[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『処理速度を早く、軽くしたい。』（くろ）
一覧表に入力したデータを専用の様式に出力してそのシートのみ保存したい。
エクセル初心者です。自分で作ってみたのですが、とても重たく、途中エクセルが真っ白になったり、応答なしになったりします。
年度でデータが入力する予定で、現在３ヶ月分のデータでこの反応だと年度終わりまで耐えれるか不安です。もっと軽い方法があれば教えてもらえると嬉しいです。
【一覧表】
A B C D E F ・・・ IS IT IU IV IW IX IY IZ JA JB JC JD JE 1 NO 日付 名前 借方1 適用1 金額1 ・・・借方84 適用84 金額84 空白 空白 空白 貸方 合計 振伝順番 貸方1 合計1 貸方2 合計2
【振伝】
1行目〜14行目までが1ブロック、15行目〜28行目までが1ブロック、29行目〜42行目までが1ブロック・・・、全部で150（レイアウトは同じもの）
1（M2） 伝票No （1つ目は必ず1なので2つ目から）
2（B4〜K4の10セル） 日付
3（B6〜I6の8セル）〜（B12〜I12の8セル） 金額1〜金額7
4（K6）〜（K12） 借方1〜借方7
5（L6〜M6の2セル）〜（L12〜M12の2セル） 適用1〜適用7
6（N6〜R6の5セル） 貸方≪貸方1≫
7（S6〜Z6の8セル） 合計≪合計1≫
8（N7〜R7の5セル） ≪貸方2≫
9（S7〜Z7の8セル） ≪合計2≫
10（N13〜R13の5セル） 名前
※（）が1セル（結合）≪≫sh1の貸方1が転記の場合
【ThisWorkBook】
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim z As Long
Dim n As Long
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
n = sh1.Cells(Rows.Count, "B").End(xlUp).Row
Application.Goto sh1.Cells(n + 1, 2), True
Application.ScreenUpdating = False
sh1.Range(Cells(2, 1), Cells(n, 1)).ClearContents
For z = 2 To n
sh1.Cells(z, 1).Value = WorksheetFunction.Subtotal(3, sh1.Range(Cells(1, 1), Cells(z, 1))) 'No
Next
Application.ScreenUpdating = True
End Sub
【一覧表】
Option Explicit
Private Sub Worksheet_Activate()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim z As Long
Dim n As Long
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
n = sh1.Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
sh1.Range(Cells(2, 261), Cells(n, 261)).ClearContents
For z = 2 To n
If sh1.Cells(z, 3).Value <> "" Then
sh1.Cells(z, 261).Value = Application.VLookup(Cells(z, 3), sh3.Range("No"), 2, False) '振伝順番
End If
Next
Range(Cells(1, 1), Cells(n, 265)).Sort Key1:=Range("B2"), _
Order1:=xlAscending, _
Key2:=Range("JA2"), _
Order2:=xlAscending, _
Header:=xlGuess ''''日付・振伝順番で昇順並び替え
Application.ScreenUpdating = True End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
削除
If Target.Column = 2 Then
全て
保存
End If
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
個別
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 260 Then Exit Sub
If Target.Column = 1 Then Exit Sub
If Target.Column = 261 Then Exit Sub
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim z As Long
Dim m As Long
Dim n As Long
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
m = 1048576
n = sh1.Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
If Cells(n, 1) = "" Then sh1.Cells(n, 1).Value = WorksheetFunction.Subtotal(3, Range(Cells(1, 1), Cells(n, 1))) 'No End If
If Target.Column = 3 Then
sh1.Cells(n, 261).ClearContents
sh1.Cells(n, 261).Value = Application.VLookup(Cells(n, 3), sh3.Range("No"), 2, False) '振伝順番
End If
Rows.EntireColumn.AutoFit '列の幅
If Target.Column = 2 Then
With Range(Cells(2, 1), Cells(m, 260))
.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
.BorderAround LineStyle:=xlNone
End With
With Range(Cells(2, 1), Cells(n + 1, 260))
.Borders.Weight = xlHairline
.BorderAround Weight:=xlMedium
End With
End If
色 合計
Application.ScreenUpdating = True
End Sub
【振伝】
Option Explicit
Private Sub Worksheet_Activate()
Dim j As Long
Dim x As Long
Application.ScreenUpdating = False
Range("L:M").ShrinkToFit = True
Range("L1:M2099").Font.ColorIndex = 1
j = Cells(Rows.Count, "M").End(xlUp).Row
For x = 4 To j Step 14
Range(Cells(x, 2), Cells(x, 11)).NumberFormatLocal = "ggge年m月d日" '''日付
Range(Cells(x + 2, 2), Cells(x + 9, 9)).NumberFormatLocal = "#,###" '''金額
Range(Cells(x + 9, 14), Cells(x + 9, 18)).Font.Size = 10 '''名前
Range(Cells(x + 2, 19), Cells(x + 2, 26)).NumberFormatLocal = "(#,###)" '''貸方
Range(Cells(x + 3, 19), Cells(x + 3, 26)).NumberFormatLocal = "(#,###)" '''貸方
Next
色
Application.ScreenUpdating = True
End Sub
【標準モジュール】
Option Explicit
Sub 合計()
Dim gyou As Long '行の番号
Dim retsu As Long '列の番号
Dim goukei As Long '合計
Dim hyouji As Long
Dim n As Long
n = Cells(Rows.Count, "F").End(xlUp).Row
Application.ScreenUpdating = False
hyouji = 0
For gyou = 2 To n
retsu = 6
Do Until Worksheets("一覧表").Cells(gyou, retsu - 1) = ""
goukei = goukei + Cells(gyou, retsu).Value
retsu = retsu + 3
Loop
Cells(gyou, 260).Value = goukei
'次の行で使うために合計を0にしておく
goukei = 0
Next
Application.ScreenUpdating = True
End Sub
Sub 色()
Dim c As Range Dim e As Range Dim a As String Dim i As String Dim w As Worksheet
Set c = Cells.Find(What:="*事業所", LookAt:=xlWhole) Application.ScreenUpdating = False If Not c Is Nothing Then a = c.Address Do c.Font.ColorIndex = 3 Set c = Cells.FindNext(c) Loop Until a = c.Address End If Set e = Cells.Find(What:="*支店", LookAt:=xlWhole) If Not e Is Nothing Then i = e.Address Do e.Font.ColorIndex = 3 Set e = Cells.FindNext(e) Loop Until i = e.Address End If Application.ScreenUpdating = True End Sub
Sub 全て()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim n As Long
Dim m As Long
Dim j As Long
Dim z As Long
Dim p As Long
Dim k As Long
Dim i As Long
Dim x As Long
Dim o As Long
Dim s As Long
Dim retsu As Long
Dim gyou As Long
Dim MyValue As Date
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
s = sh2.Cells(Rows.Count, "M").End(xlUp).Row
n = sh1.Cells(Rows.Count, "F").End(xlUp).Row
j = sh1.Cells(Rows.Count, "B").End(xlUp).Row
z = 6
Application.ScreenUpdating = False
sh1.Select
MyValue = Application.InputBox("年月を入力してください（例）4/30", Type:=1)
If MyValue = False Then Exit Sub
For gyou = 2 To j If sh1.Cells(gyou, 2) = MyValue Then retsu = 6 p = 1 m = sh2.Cells(Rows.Count, 13).End(xlUp).Row If sh2.Cells(m, 13) <> "1" Then sh2.Cells(m, 13).Value = p End If sh2.Cells(m + 4, 14).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 259, False) 6 sh2.Cells(m + 4, 19).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 260, False) 7 k = 4 Do Until sh1.Cells(gyou, retsu - 1) = "" i = 0 sh2.Cells(m + 2, 2).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 2, False) 2 sh2.Cells(m + 11, 14).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 3, False) 10 Do Until i = 7 sh2.Cells(i + z, 11).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), k, False) 4 sh2.Cells(i + z, 12).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), k + 1, False) 5 sh2.Cells(i + z, 2).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), k + 2, False) 3 k = k + 3 i = i + 1 Loop p = p + 1 retsu = retsu + 21 k = retsu - 2 sh2.Cells(m + 14, 13).Value = p 1 m = sh2.Cells(Rows.Count, 13).End(xlUp).Row z = m + 4 Loop End If
For o = 6 To s Step 14
If sh2.Cells(o, 14).Value = "転記" Then
sh2.Select
sh2.Range(Cells(o, 14), Cells(o, 26)).ClearContents
sh1.Select
sh2.Cells(o, 14).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 262, False) 6
sh2.Cells(o, 19).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 263, False) 7
sh2.Cells(o + 1, 14).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 264, False) 8
sh2.Cells(o + 1, 19).Value = Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 265, False) 9
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Sub 個別()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim n As Long
Dim k As Long
Dim i As Long
Dim gyou As Long
Dim retsu As Long
Dim p As Long
Dim m As Long
Dim j As Long
Dim z As Long
Dim MyValue As Long
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
n = sh1.Cells(Rows.Count, "A").End(xlUp).Row
j = sh1.Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
sh1.Select
MyValue = Application.InputBox("Noを入力してください", Type:=1)
If MyValue = False Then Exit Sub
z = 6
retsu = 6
p = 1
m = sh2.Cells(Rows.Count, 13).End(xlUp).Row
If sh2.Cells(m, 13) <> "1" Then
sh2.Cells(m, 13).Value = p
End If
sh2.Cells(m + 4, 14).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), 259, False)
sh2.Cells(m + 4, 19).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), 260, False)
gyou = MyValue + 1
k = 4
Do Until sh1.Cells(gyou, retsu - 1) = ""
i = 0
sh2.Cells(m + 2, 2).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), 2, False)
sh2.Cells(m + 11, 14).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), 3, False)
Do Until i = 7
sh2.Cells(i + z, 11).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), k, False)
sh2.Cells(i + z, 12).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), k + 1, False)
sh2.Cells(i + z, 2).Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(j, 265)), k + 2, False)
k = k + 3
i = i + 1
Loop
p = p + 1
retsu = retsu + 21
sh2.Cells(m + 14, 13).Value = p
m = sh2.Cells(Rows.Count, 13).End(xlUp).Row
z = m + 4
Loop
If sh2.Range("N6").Value = "転記" Then
sh2.Range("N6:Z7").ClearContents
sh2.Range("N6").Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(n, 265)), 262, False)
sh2.Range("S6").Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(n, 265)), 263, False)
sh2.Range("N7").Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(n, 265)), 264, False)
sh2.Range("S7").Value = Application.VLookup(MyValue, sh1.Range(Cells(2, 1), Cells(n, 265)), 265, False)
End If
sh2.Select Application.ScreenUpdating = True End Sub
Sub 保存()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
Dim fileName As String
Dim MyDate As String
Application.ScreenUpdating = False
MyDate = sh2.Range("B4")
fileName = ThisWorkbook.Path & "\" & Month(MyDate) & "月" & ".xlsx"
sh2.Select
Cells.Select
Selection.Copy
Worksheets.Add 'コピー先シート追加
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Name = "1"
Sheets("1").Move
Sheets("1").Select
Sheets("1").Name = Month(MyDate) & "月"
ActiveWorkbook.SaveAs fileName '名前をつけて保存
Application.ScreenUpdating = True
End Sub
Sub 削除()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim x As Long
Dim s As Long
Set sh1 = Worksheets("一覧表")
Set sh2 = Worksheets("振伝")
Set sh3 = Worksheets("リスト")
s = sh2.Cells(Rows.Count, "M").End(xlUp).Row
Application.ScreenUpdating = False
sh2.Select
For x = 4 To s Step 14
sh2.Range(Cells(x, 2), Cells(x, 11)).ClearContents '''日付
sh2.Range(Cells(x + 2, 2), Cells(x + 8, 26)).ClearContents '''内容
sh2.Range(Cells(x + 9, 14), Cells(x + 9, 18)).ClearContents '''名前
sh2.Cells(x + 12, 13).ClearContents '''ＮＯ
Next
Application.ScreenUpdating = True
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows8 ＞
質問文とコードは、まだよく読んでいませんが、 モジュールの先頭に Option Explicit を記述するようにしましょう。 アップされたコードでは、変数をきちんと定義しておられるように見受けられますが それでも、定義が retu で、実際のコードでは retsu といった うっかりミスが避けられますから。
それと、定義の書き方として
Dim n, m, J, Z, P, K, i, x, O, retu, gyou As Variant
これは、gyou のみ 指定のデータ型、他は Variant型になるということは認識した上での記述でしょうか？ たまたま gyou以外は変数規定がなく、デフォルトとしての Variant型になりますので、結果はオーライですが？
その結果はオーライも、そうかな？と思います。これら変数のデータ型として、本当に Variant型が適切なのですか？ Long型が適切なのでは？
であれば
Dim n As Long, m As Long, J As Long, Z As Long, P As Long, K As Long, i As Long, x As Long, O As Long, retsu As Long, gyou As Long
と記述します。（あるいは変数を１行ずつ記述したほうが、行数は増えますがわかりやすいかも）
（β） 2015/06/18(木) 19:06
質問です。
プロシジャ "個別"コードがアップされていませんが、ここでは、遅くなる要因は絶対にないので割愛されたのですか？
それと、
For O = 6 To 2092 Step 14
や
For x = 4 To 2090 Step 14
いずれも、振替伝票のシートを処理している行番号ですが、この 2092 や 2090 には意味があるのですか？ それとも、データ最終行までという意味ですか？ （データ最終行にしては 2092 と 2090 という異なった数値指定があるのは？？）
（β） 2015/06/18(木) 19:12
まだコードは精読していません。
まず、一覧表のレイアウトをこちらでおこしてみました。 すざましいレイアウトですねぇ。これって、どこかのシステムからダウンロードされるデータですか？ それとも、人間が入力するシートですか？ もし、人間が入力するシートだとすると、入力作業そのものが横スクロール含めて大変じゃないですか？ 借方が８５個、貸方が１つ（ですよね？）リスト伝票のようなものですかね。 通常、人間が入力するリスト伝票は、縦に展開するレイアウトが圧倒的に多いと思いますが、その点、いかがですか？
で、肝心のコードですが、振伝シートとリストシートのレイアウトが記載されていません。 コードの大部分は振伝シートを相手にしていますので、このレイアウトがどうなっているのか、また、そこには どこから、どういう条件で転記されるのか、そういったことがわからないと、回答する立場としては、しんどいです。
まさか、コードを追いかけて分析して、処理要件とレイアウトを理解してくださいということではないですよね？
（β） 2015/06/18(木) 19:42
個別に関しては、今回B列をダブルクリックした場合が遅いので、割愛してます。
振替伝票シートの最終行までという意味で間違いないです。
基準にしてる行が違うために２行づつズレてます。
人間が手入力してます。
始めに作ったのが個別の方で、A列の番号を入れたらその行の内容を振伝を出力というものしか作れなかったので、横に入力は難しいですが私の知識の限界でした。（縦の場合のレイアウトが思いつきませんでした）
リストシートはリストボックスの内容を入れてるので不要だと思います。
振伝シートはかなり細かいので、エクセルが貼り付ければいいのですが。
何かいい方法は無いですかね？
（くろ） 2015/06/18(木) 21:24
想像するに、振伝シートは ４行目〜１７行目までが１ブロック、１８行目〜３１行目までが１ブロック、・・・・
各ブロックのレイアウトは同じ。
だとしたら、１ブロック目のみでいいので、具体的に、そのレイアウトを説明してください。 (B4〜K4の１０セルが日付とか） で、その１ブロック目の、どこをどのようにしているのか、それを具体的に書いてください。 N6にはどこをどの領域でどんな検索をした結果をセットするとか。
たとえば
Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(J, 265)), 262, False)
これは、何を、どの領域のどことマッチングさせて、その何をひっぱってきたいのか、「言葉で」お願いします。 （一覧シートの gyou という変数に入った行のB列の値で、・・・・ ということではなく）
（β） 2015/06/18(木) 22:05
お手数かけて申し訳ございません。
1ブロックのみならできそうです。
データが会社にあるので、明日また返事させて頂きます。
よろしくお願いします。
（くろ） 2015/06/18(木) 22:22
上に記入させて頂きました。
尚、アドバイスを頂いた部分等、若干の変更してます。
振伝の説明の前の番号は【標準モジュール】の全て（）の右の数字の事です。
後、他のマクロ全て追加させてもらいました。
リストシートは「No.・科目・名前」を名前の定義した一覧のみ記入してるので割愛します。
宜しくお願いします。
（くろ） 2015/06/19(金) 11:16
これから整理してもらったコードを再読し、追加説明も読んでみますが
（β） 2015/06/18(木) 22:05 でお願いした、そもそも、何をどうしようとしているのかという 処理要件の言葉での説明がほしいと思っています。
とくに（と書くと、ここだけを説明して終わりになるといやなんですが）ループの中で VLOOKUP を多用。 あきらかに、同じ値で同じ領域を検索し、たんに、各行で、その抽出位置が異なるだけ。 これは、いかにも、「処理時間を長くするために」書かれているコードとしか思えません。
ここは、何を元に、どこの領域の何をチェックしているのか、それを「言葉」で書いてほしいのですが。
（β） 2015/06/19(金) 19:24
一覧シートの1行毎に1人社員のデータを入力してます（データの最終列はバラバラ）
1人社員のデータ（日にち指定）または同日にちのデータ全てを振伝シートに出力したいです。
列は金額が最終列ではなく、適用が最後の場合がある。
【一覧シート】
1、日付を入れるとA列に番号、罫線を引く（Worksheet_Change）
2、名前を入れるとJA列にsh3のNoに定義した番号（Worksheet_Change）
3、適用に文字が入ってる場合、金額の合計をIZ列（Worksheet_Change）
4、IY列に転記と入力した場合、JB列 JC列 JD列 JE列の値に変更（Worksheet_Change）
5、適用に**事業所か**支店がある場合は文字を赤（Worksheet_Change）
6、B列とJA列を基準に昇順で並び替え（Worksheet_Activate）
7、sh3のNoに定義した内容を変更した場合、sh1の振伝番号変更（Worksheet_Activate）
8、1人社員のデータ（日にち指定）または同日にちのデータ全てを振伝シートに出力（BeforeDoubleClick）
9、同日にちのデータ全てを振伝シートに出力後、sh2.Range("B4")の日付の月でシート名とファイル名で保存（BeforeDoubleClick）
【振伝シート】（結合）
1、（L列〜M列）の文字は列の幅にあわせる（Worksheet_Activate）
2、（L列〜M列）に**事業所か**支店がある場合は文字を赤（Worksheet_Activate）
3、書式：日付"ggge年m月d日" 金額"#,###" 名前 Font.Size = 10（Worksheet_Activate）
これで伝わりますか？
（くろ） 2015/06/19(金) 21:09
振伝シート 一覧表シート （M2） 伝票No 1(手入力） （B4〜K4の10セル） 日付(B) （B6〜I6の8セル） 金額1(F) （K6） 借方1(D) （L6〜M6の2セル） 適用1(E) (B7〜I7の8セル） 金額2(I) （K7） 借方2(G) （L7〜M7の2セル） 適用2(H) (B8〜I8の8セル） 金額3(L) （K8） 借方3(J) （L8〜M8の2セル） 適用3(K) (B9〜I9の8セル） 金額4(O) （K9） 借方4(M) （L9〜M9の2セル） 適用4(N) (B10〜I10の8セル） 金額5(R) （K10） 借方5(P) （L10〜M10の2セル） 適用5(Q) (B11〜I11の8セル） 金額6(U) （K11） 借方6(S) （L11〜M11の2セル） 適用6(T) (B12〜I12の8セル） 金額7(X) （K12） 借方7(V) （L12〜M12の2セル） 適用7(W) （N6〜R6の5セル） 貸方(IY)≪貸方1≫(JB) （S6〜Z6の8セル） 合計(IZ)≪合計1≫(JC) （N7〜R7の5セル） ≪貸方2≫(JD) （S7〜Z7の8セル） ≪合計2≫(JE) （N13〜R13の5セル） 名前(C) （M16） 伝票No（同一人物なら+1、人が変わったら1から） ※（）が1セル（結合）≪≫sh1の貸方1が転記の場合 貸方は1枚目のみ入力（同一人物の）
これが1ブロックです。
追加で、全てのデータを保存するとき、印刷の余白を上下左右全部0mmに指定するやり方も教えてもらえると嬉しいです。
（くろ） 2015/06/19(金) 22:55
>>追加で、全てのデータを保存するとき、印刷の余白を上下左右全部0mmに指定するやり方も教えてもらえると嬉しいです。
現在の課題も、早急に回答ができるとは思えません。 これからも、Ｑ／Ａを繰り返すでしょうし。まだまだ、現状が把握できていませんので。
なので、印刷の件は、必要であれば、別トピをたてられてはいかが？ というか、今回のマクロ処理とは切り離し、単純に、印刷余白設定の問題ですから ページレイアウトタブの余白ですべての余白をゼロにする、その設定操作をマクロ記録すれば マージン以外の設定もコード化されますが、それらは割愛して、マージン部分だけをピックアップした コードでいけるのでは？ (With/End WIth 含めて８行）
（β） 2015/06/20(土) 01:01
理解状況、30%程度まで進んでいます。
とりあえず、現時点で質問４点。
１．説明に時々 "転記" という言葉が出てきます。コードでも、振伝シートのＮ列の値が "転記"かどうかをチェックしています。 この "転記" というのは何ですか？
２．一覧表シート、１行が８４伝票分だと思いますが、ある人の伝票がそれ以上だとすれば、同じ人で何行もあると考えていいですか？
３．その場合、同じ人は連続していますか？
４．一覧表シートから振伝シートに転記するわけですが、振伝シートは、１５０ブロックですよね。 伝票が、それ以上あればどうしたらいいですか？
（β） 2015/06/20(土) 02:22
解析度、35%ぐらいになったでしょうか。とにかく牛歩ですので、すべての解析には、まだまだ時間がかかると思います。 これから、ある程度のまとまりごとに、理解したと思われる解釈をレスしていきます。 もし、それは違うよということがあれば、都度、指摘願います。
この解析は、（くろ） 2015/06/19(金) 17:43 で変更されたと思われる、掲載されたコードをもとにしています。 もし、今後、そちらのほうで、何らかの必要性があってコードを変更される場合は、直しておいたよ ではなく ここを、このように直したという連絡にしてもらえますか？ じゃないと、どこがどうかわったかわからないので、いままでの整理解析結果をすべてすてて、また１から コードをおいかける必要がでてきますので。
コードをおいかけていると、このタイミングのこの処理じゃだめだろうなとか、このコードの書き方は効率が悪いとか このコードは不要だなとか いろいろ目につきますが、基本的にそれらは、今はさわらず、解析を進めます。
●リストシート
どこかに"No"という名前の付けられた２列の領域があって、１列目に名前、２列目に、一覧表シートの並び順（優先順）。 おそらくは、２列目は上から、１，２，３，４、・・・・ で、この領域を参照して、一覧シートのＪＡ列に番号が振られ、並び替えのキーになる。 この一覧シートのＪＡ列は、一覧シートの並び替えにのみ使われている。
●ワークブックモジュール
ブック保存時に、 ・（次回開いたときのために）一覧シートＢ列最終行の次のセルを選択（一覧シートがアクティブシートになる） ・Ａ列の連番を振り直し
★でも、振伝順番での並び替えは実行せず。
●一覧シートのシートイベント
（Activate）
・ＪＡ列の並び順をクリアし ・そこに、リストシートの "No" を参照して、ＪＡ列の振伝順番をセットし ・日付昇順、振伝順番昇順で並び替え。
（Change）
・まず、ＩＺ列（合計）、Ａ列（Ｎｏ．），ＪＡ列（振伝順番）の変更なら何もせず。 おそらく、これは、このシートのActivate、Changeで行っている振伝順番の書き込み、Changeで（これから行う）Ｎｏ．の書き込みによる イベントをスキップする目的？（合計列を聞いているのは、今のところなぜかはわかっていません） ・Ａ列が空白なら連番をセット ・Ｃ列（名前）の変更ならＪＡ列の振伝順番を書き換え ・全列幅自動調整 ・シートにあるすべての罫線を消し ・データ領域に囲み罫線セット
その後、プロシジャ "色"、"合計" を実行。（これら処理は未解読）
（BeforeDoubleClick）
・"削除" を実行 ・Ｂ列ダブルクリックなら、"全て"、"保存" を実行 ・Ａ列ダブルクリックなら、"個別" を実行。
（"全て"、"保存"、"個別" については未解読）
（β） 2015/06/20(土) 08:21
分析報告の続きです。
●一覧シートのシートイベント 追記
Activate の目的は、リストシートで名前の追加や順番の変更などを行った際に、一覧シートにそれを反映させるため 一覧シートの戻った時に、並び替えを実施することだろうと認識しました。 一覧シートを表示させないと、全体なり個別なりの処理が動きませんので、逆にいえば、表示させた時点で行えば十分ということでしょうね。 振伝シートをアクティブにしてから一覧シートに戻った際にも動きますが、まぁいいかという割り切りですかね？
ところで、Changeイベント。１つの伝票を追加する際、最低でも、借方、適用、金額の３つのセルに入力しますよね。 ということは、最低でも３回のChageイベントが発生。同じ処理を３回することになりますね。これも割り切りでしょうかね？
●振伝シートのシートイベント Activate
振伝シートに対して以下の処理を実行。
・Ｌ列、Ｍ列（適用）の文字がセル内でおさまるように、文字の大きさを適宜縮小 ・Ｍ，Ｌ列の１５０ブロック領域のセルの文字色を黒にする。（ 1 ではなく xlAutomatic がベターだとは思いますが） ・４行目からＭ列データ最終行までの１４行単位の領域のしかるべきところの書式をセットしたり文字色をセット。
なぜＭ列で最終行を判定しているのか、？？？ と思いますし、ここはコードで処理せず、あらかじめセル書式をセットしておけばいいのに？？ とも思いますが、もしかしたら、未解読のプロシジャで、別書式にしているのかもしれませんので、現時点ではノーコメント。
さぁ、あとは、これから、標準モジュールを解析します。
（β） 2015/06/20(土) 12:01
標準モジュール（その１）
●合計
一覧表シートのChangeイベントで実行される。したがって、一覧表シートがActiveSheetであるという前提のコード。
・Ｆ列（金額1)基準でデータ最終行を求め（なぜＦ列基準なのか、いまいちわかりませんが。） ２行目からデータ最終行までの各行に対し、適用欄に値のある伝票データの金額を足しこんで ＩＺ列（合計）にセット。摘要欄が空白のところで足し込はおしまい。（そのために最後の伝票の右の３セルを空白にしてあるんでしょうね）
★これも、あらかじめ式を入れておけば、このプロシジャそのものが不要になると思いますがね。
●色
一覧表シートのChangeイベント、および 振伝シートの Activateイベントで実行される。 したがって、その時のActiveシートは、一覧表シート、もしくは振伝シート。（★いいのかなぁ）
・シート上の なんとか事務所 を検索。 ・あれば、そのセルを赤で塗りつぶし。 ・なんとか支店を検索 ・あれば、そのセルを赤で塗りつぶし
★具体的に、これらあの語句があるのは、一覧シート、振伝シートの、どの領域なんですか？
●保存
一覧表シートでＢ列（日付列）がダブルクリックされたとき、削除->全て->保存の順で実行される。
・ワークシートを、【自分自身（このマクロブック）】に追加し、そこに【振伝シート】を、値と書式コピー。 ・そのシートのみをMoveメソッドで単独ブックとして、シート名を○○月、ブック名を ○○月.xlsx として マクロブックと同じフォルダに保存。
★まぁ、問題はないですが、一覧表シートでのダブルクリックで、一覧表シートには関係なく全く別のシートの 処理をしているというのが、ちょっと？ですけど、皆さん、この手順で慣れているんでしょうからね。 なんとなく、振伝シートでのダブルクリックなら、わかりやすいのかなぁとも思います。
●削除
一覧表シートで、【どこでも】ダブルクリックすると、最初に実行される。（★いいのかなぁ？？？？？）
例によって（？）一覧表シートとは関係なく、
・振伝シートのＭ列（No 欄？）基準で、データ最終列を取得し、（★なぜＭ列基準なのかなぁ？？？？？） ・各ブロックの日付欄、内容欄、名前欄、Ｎｏ欄をクリア（★４行目から始めていますがわかりにくいですねぇ）
◎全て と 個別 は次回。
（β） 2015/06/20(土) 14:26
あとは、全て と 個別 の解析です。 もちろん、コードそのものはわかりますが、何のために何をしているのか、ここは（例のＶＬＯＯＫＵＰの多用の部分もありますね） （くろ） さん自身の「言葉」で、今まで他の部分に対してβが整理したような感じで、説明いただけませんか？
その説明をもらい、（β） 2015/06/20(土) 02:22以降にレスした解釈や質問に対する返答をもらった後に、コード案を書きだす予定です。
（β） 2015/06/20(土) 15:08
印刷範囲の件は、一度試してみたけどうまくいかなかったんですが、再度チャレンジしてみます。
＞＞１．説明に時々 "転記" という言葉が出てきます。コードでも、振伝シートのＮ列の値が "転記"かどうかをチェックしています。
この "転記" というのは何ですか？ 基本的には貸方は借方の合計なのですが、まれに２段書きになるのでその場合は一覧表のIY列に"転記"JB列JC列JD列JE列に実際出力したい科目と金額入力、 マクロ実行後、振伝シートにJB列JC列JD列JE列の値を表示。 それを一連で書けなかったので、まず振伝シートのN列に"転記"がでたら再度JC列JD列JE列の値に変更という形になってしまいました。
＞＞ ２．一覧表シート、１行が８４伝票分だと思いますが、ある人の伝票がそれ以上だとすれば、同じ人で何行もあると考えていいですか？
はい。
＞＞ ３．その場合、同じ人は連続していますか？
連続します。同一人物でも上の行が84伝票まで入力してない場合は、伝票番号は1行毎に1始まりにしたいです。
＞＞４．一覧表シートから振伝シートに転記するわけですが、振伝シートは、１５０ブロックですよね。
伝票が、それ以上あればどうしたらいいですか？
それ以上の場合も出力したいです。（前年度の枚数を参考に150にしてるだけです）
＞＞●リストシート
どこかに"No"という名前の付けられた２列の領域があって、１列目に名前、２列目に、一覧表シートの並び順（優先順）。 おそらくは、２列目は上から、１，２，３，４、・・・・ で、この領域を参照して、一覧シートのＪＡ列に番号が振られ、並び替えのキーになる。 この一覧シートのＪＡ列は、一覧シートの並び替えにのみ使われている。
その通りです。
＞＞ ●ワークブックモジュール
ブック保存時に、 ・（次回開いたときのために）一覧シートＢ列最終行の次のセルを選択（一覧シートがアクティブシートになる） ・Ａ列の連番を振り直し ★でも、振伝順番での並び替えは実行せず。
・Ａ列の連番を振り直しは本当はし下の（Activate）に書いていたのですが、動作が重いので分けました。本当は振伝順番での並び替えと一緒にしたいです。
＞＞●一覧シートのシートイベント
（Activate） ・ＪＡ列の並び順をクリアし ・そこに、リストシートの "No" を参照して、ＪＡ列の振伝順番をセットし ・日付昇順、振伝順番昇順で並び替え。
その通りです。
（Change）
・まず、ＩＺ列（合計）、Ａ列（Ｎｏ．），ＪＡ列（振伝順番）の変更なら何もせず。
おそらく、これは、このシートのActivate、Changeで行っている振伝順番の書き込み、Changeで（これから行う）Ｎｏ．の書き込みによる イベントをスキップする目的？（合計列を聞いているのは、今のところなぜかはわかっていません） ・Ａ列が空白なら連番をセット ・Ｃ列（名前）の変更ならＪＡ列の振伝順番を書き換え ・全列幅自動調整 ・シートにあるすべての罫線を消し ・データ領域に囲み罫線セット
＞＞合計列を開いている
これについては質問がよくわかりません。
それ以外は間違いないです。
＞＞（BeforeDoubleClick）
・"削除" を実行
・Ｂ列ダブルクリックなら、"全て"、"保存" を実行 ・Ａ列ダブルクリックなら、"個別" を実行。
その通りです。
＞＞●一覧シートのシートイベント 追記
Activate の目的は、リストシートで名前の追加や順番の変更などを行った際に、一覧シートにそれを反映させるため 一覧シートの戻った時に、並び替えを実施することだろうと認識しました。 一覧シートを表示させないと、全体なり個別なりの処理が動きませんので、逆にいえば、表示させた時点で行えば十分ということでしょうね。 振伝シートをアクティブにしてから一覧シートに戻った際にも動きますが、まぁいいかという割り切りですかね？ 目的はその通りです、シートチェンジで一覧シートに戻った時にも動くのは、止め方が分からないのでそのままです。
ところで、Changeイベント。１つの伝票を追加する際、最低でも、借方、適用、金額の３つのセルに入力しますよね。 ということは、最低でも３回のChageイベントが発生。同じ処理を３回することになりますね。これも割り切りでしょうかね？
そうなんです、止めたいんですけど、やり方がわからないのでこれもそのままです。
割り切りというより、そんなやり方があるのを知らないから疑問に思ってないだけです。すいません。
こういう無駄な処理が遅い原因なんですか？
＞＞●振伝シートのシートイベント Activate
振伝シートに対して以下の処理を実行
・Ｌ列、Ｍ列（適用）の文字がセル内でおさまるように、文字の大きさを適宜縮小 ・Ｍ，Ｌ列の１５０ブロック領域のセルの文字色を黒にする。（ 1 ではなく xlAutomatic がベターだとは思いますが） ・４行目からＭ列データ最終行までの１４行単位の領域のしかるべきところの書式をセットしたり文字色をセット。
その通りです。
＞＞なぜＭ列で最終行を判定しているのか、？？？ と思いますし、ここはコードで処理せず、あらかじめセル書式をセットしておけばいいのに？？
私のマクロだと、最終振伝の次のＮｏも入力されるので、Ｍが基準になってしまいました。
後、他の列だと、もともとの入力してある文字で最終行が止まってしまうためです。
あらかじめセル書式をセットとはマクロではなくてエクセルリボンのを使ってってことですか？
＞＞●合計
一覧表シートのChangeイベントで実行される。したがって、一覧表シートがActiveSheetであるという前提のコード ・Ｆ列（金額1)基準でデータ最終行を求め（なぜＦ列基準なのか、いまいちわかりませんが。） ２行目からデータ最終行までの各行に対し、適用欄に値のある伝票データの金額を足しこんで ＩＺ列（合計）にセット。摘要欄が空白のところで足し込はおしまい。（そのために最後の伝票の右の３セルを空白にしてあるんでしょうね）
★これも、あらかじめ式を入れておけば、このプロシジャそのものが不要になると思いますがね。
F列が基準なのは意味はないです、金額に使うので後で見た時にすぐわかるようにくらいです。
あらかじめ式を入れるという作業がいまいち何を指してるのかわかりません。
あとはその通りです。
＞＞ ●色
一覧表シートのChangeイベント、および 振伝シートの Activateイベントで実行される。 したがって、その時のActiveシートは、一覧表シート、もしくは振伝シート。（★いいのかなぁ）
・シート上の なんとか事務所 を検索。 ・あれば、そのセルを赤で塗りつぶし。 ・なんとか支店を検索 ・あれば、そのセルを赤で塗りつぶし
★具体的に、これらあの語句があるのは、一覧シート、振伝シートの、どの領域なんですか？ 一覧シートの適用 振伝シートの（L列M列）結合セルです。
＞＞●保存
一覧表シートでＢ列（日付列）がダブルクリックされたとき、削除->全て->保存の順で実行される。
・ワークシートを、【自分自身（このマクロブック）】に追加し、そこに【振伝シート】を、値と書式コピー。 ・そのシートのみをMoveメソッドで単独ブックとして、シート名を○○月、ブック名を ○○月.xlsx として マクロブックと同じフォルダに保存。
★まぁ、問題はないですが、一覧表シートでのダブルクリックで、一覧表シートには関係なく全く別のシートの 処理をしているというのが、ちょっと？ですけど、皆さん、この手順で慣れているんでしょうからね。 なんとなく、振伝シートでのダブルクリックなら、わかりやすいのかなぁとも思います。
そうなんですね、そういう手順はやったことが無いのでしりませんでした。
内容はその通りです。
＞＞ ●削除
一覧表シートで、【どこでも】ダブルクリックすると、最初に実行される。（★いいのかなぁ？？？？？）
例によって（？）一覧表シートとは関係なく、
・振伝シートのＭ列（No 欄？）基準で、データ最終列を取得し、（★なぜＭ列基準なのかなぁ？？？？？） ・各ブロックの日付欄、内容欄、名前欄、Ｎｏ欄をクリア（★４行目から始めていますがわかりにくいですねぇ）
私のマクロだと、最終振伝の次のＮｏも入力されるので、Ｍが基準になってしまいました。
後、他の列だと、もともとの入力してある文字で最終行が止まってしまうためです。
1枚目の振伝Ｎｏ(M2)をマクロで入力してないからです。入力されるのなら2行目からで問題ないです。
【個別】
出したい行の番号をＶＬＯＯＫＵＰで検索してそれぞれの列の値を振伝にだしてます。
【全て】
出したい日付ををＶＬＯＯＫＵＰで検索してそれぞれの列の値を振伝にだしてます。
値を探すためにＶＬＯＯＫＵＰ使ってます、多用といわれるのはよくわかりません。
（くろ） 2015/06/20(土) 16:54
>>値を探すためにＶＬＯＯＫＵＰ使ってます、多用といわれるのはよくわかりません。
たとえば、"全て" の VLOOKUP の最初、左辺は無視して右辺、
Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 259, False)
j は 一覧表 Ｂ列（日付）のデータ最終行番号ですね。仮にそこが 1000行目だとします。 gyou が 10行目だとしましょうか。
VLOOKUP(sh1.Range("A10"),sh1.Range("A2:JE1000"),259,False) ですよね。
A10の値で、sh1.Range("A2:JE1000") の１列目を検索してその行を取得して、その領域のIY列（貸方）を取り出しますね。
２つめのVLOOKUP は
Application.VLookup(sh1.Cells(gyou, 1), sh1.Range(Cells(2, 1), Cells(j, 265)), 260, False)
ですね。つまり、
VLOOKUP(sh1.Range("A10"),sh1.Range("A2:JE1000"),260,False) ですよね。
ここでも、A10の値で、sh1.Range("A2:JE1000") の１列目を検索してその行を取得してますよね。
同じ行のすべてのVLOOKUP がそうなっています。すべてのVLOOKUPの結果は【同じ行】ですね。 何度も何度も、１列目を同じ値でチェックしていることはおわかりでしょうか？
やるなら、たとえば、シート関数のMATCHがありますよね。これで、該当の行を検索して行番号を取得。 その行の、260列とか259列から直接値をひっぱってくればいいですよね。
というか（ここは、βの理解が間違っているかもしれませんが）そもそも一覧表のＡ列の値ってユニークじゃないのですか？ つまり、A10 の値で A列をVLOOKUP すると、返ってくるのは 10行目の各セルの値じゃないのですか？ もし、そうなら、VLOOKUPもMATCHもいりませんよね。 10行目の(つまり gyou の）260列とか259列の値を取り出せばいいのでは？
（β） 2015/06/20(土) 17:35
おおまかな構造はほぼ理解できたと思います。個別には、？？？というところもありますが それは、すり合わせながら、なんとかいけるような気がします。
ただ、この処理をβが書くなら、オリジナルの構成とは、まったくことなった構えになるような気がします。 そうすると、(くろ)さんの本来の目的、自分が書き上げたコードのどこが悪かったんだろうということの追及が できなくなってしまいますね。悩ましいところです。
VLOOKUPについて、それは不要じゃないのかなというレスを１つ上でしていますので、それがβの誤解でなかったら、 そちらで、gyou からの直接参照に変更して試してみるのもいいかもしれません。
★固まったようになってしまうのは、何の処理をしているときですか？ 確かにイベントが複数回実行されるコードですけど それは入力中の話ですね。入力中に固まるのですか？それともダブルクリックをして、"全て" なり "個別" なりを実行した時に 固まるのですか？
それはそれとして、回答いただいたものにレスします。（最後の VLOOKUP についおては、すでにコメントしましたので、それ以外を）
>>転記
わかりました。
>>同じ人が複数行、連続
了解。
>>同一人物でも上の行が84伝票まで入力してない場合は、伝票番号は1行毎に1始まりにしたいです。
よくわからないので、具体例で教えてくれますか？ ★ それと、一覧シートＡ列のNo.は全データ通して、１からの連番ですよね？ で、振伝のNo.は人単位で 1からの連番ですよね？
>>伝票150以上サポート。
できる方向で考えてみます。
>>リストシートの名前領域
了解。
>>ワークブックモジュール ・Ａ列の連番を振り直しは本当は下の（Activate）に書いていたのですが、動作が重いので分けました。本当は振伝順番での並び替えと一緒にしたいです。
なんとか重くない方法で対応しようと思ってます。
>>ＪＡ列の振伝順番をセットし日付昇順、振伝順番昇順で並び替え。
今、ＪＡ列を使わない（リストシートの優先順番号も使わない）並び替えを考えています。
>>合計列を聞いているのは、今のところなぜかはわかっていません
If Target.Column = 260 Then Exit Sub ここのことですが？260列（ＩＺ列）って合計ですよね？
>>（BeforeDoubleClick）
★追加で。 B列（日付）ダブルクリック -> 全て は、指定日付のもの全てということだとおもうのですが A列（No.)ダブルクリック -> 個別 は、その行のみということでいいですか？
>>振伝シートシートから戻った時 Activate実施の抑止
逆に、リストシートのDeActivate に移してやることで、いけると思っています。
>>そうなんです、止めたいんですけど、やり方がわからないのでこれもそのままです。
実は、一覧表シートのChangeイベントをなくしてしまう提案をしようと考えています。
>>最終行
やはり、一覧表シートにしろ、振伝シートにしろ、どこか１つのところでデータ最終行の判断をするほうが コードの保守を考えたときに得策です。これについては、いずれ具体案を提案します。
>>あらかじめセル書式をセットとはマクロではなくてエクセルリボンのを使ってってことですか？
はい。いわゆるエクセルのセルの書式設定です。これも、いずれ提案します。
>>あらかじめ式を入れるという作業がいまいち何を指してるのかわかりません。
いや、言葉通り、IZ列のセルに式をいれておけばいいということですが？ さらに、この一覧表をテーブル設定しておけば最終行にデータを追加すると自動的に、上の行の書式や数式がコピーされます。
>>●色 一覧シートの適用、振伝シートの（L列M列）結合セルです。
了解です。（それにしては検索領域が Cells ですよね？）
>>一覧表シートでのダブルクリック
これはβが、コードをすべて読む前の思いこみで、やはり、一覧シートでのダブルクリックが 素直な流れですので放念ください。
（β） 2015/06/20(土) 18:44
大事な質問を忘れてました。
振伝シートは処理のつど、まずからっぽにして、最初からセットしていくと理解しているんですが それにしては、コードの中で振伝シートのデータ最終行を判定していおるところがありますね？
私の勘違いでしょうか？？
★追加で
一覧シート、最大でどれぐらいの行数になる見込みですか？
★もう１つ
一覧シートのレイアウトを変更するというのは可能ですか？ たとえば、IYからJAを削除して、貸方、合計、貸方2、合計2 にしてしまうとか。 通常は、貸方、合計 に記載。２段になる場合にのみ 貸方2、合計2 を使うとか。 （振伝順番は使わなくても必要な順番で並び替えはできますので）
（β） 2015/06/20(土) 18:59
質問している件については、回答をお願いしますが、コードを（一部見切りで）書き始めます。
おおまかな方針としては
・あらかじめシート上に数式や書式で設定できるものは設定しておき、ＶＢＡコード処理を減らす。 ・一覧表はテーブル設定をしておき、新規追加行に自動的に書式や数式がコピーされるようにする。（これもＶＢＡコード処理を減らす目的） ・一覧表の罫線はテーブル機能で付加されるものを使う。（ＶＢＡコードではセットしない） ・一覧表の正規化（連番の振り直しやソート等）は、一覧表のセルイベントでは対応せず、 １．ダブルクリックされ振伝作成要求がでた時点で実行 ２．リストシートから戻った時に、リストシートのDeActivateイベントで実行 ３．マクロブックの保存時に BeforeSave で実行 ４．気になって、正規化したいときにはいつでも実行可能 ・振伝シートをなくし、以下の構えにすることで１５０ブロック以上の生成に対応。 １．１４行の１ブロックの雛形のみを持ったシートをつくっておき ２．振伝要求が出たときに前の振伝シートがあればそれを削除した上で ３．新規シートを追加し ４．作成すべき振伝データ数にあわせて、雛形シートから新規シートにコピペし ５．そこに一覧表から必要なデータを転記 ・一覧表データの並び替えはリストシートの "No"領域の"名前列"のみを利用し、その名前の順序をユーザ設定並び替えリストとして使う。 "No"領域は１列のみでＯＫ．２列目があっても、その番号は参照しない。したがって一覧表の振伝順番列への値セットも行わない。 ・ループ処理で、値をセットしているところで、可能なものは、できるだけ一括転記として、処理時間を軽減する。 ・一覧表シート、埋め込んだ数式等を壊されないように、シート保護を掛ける。ただし、操作者の基本的な操作はすべてできるような保護にする。 これはブックのOpenイベントで自動実行。
こんな感じでコードを書いてみようと思っています。 なお、最初の準備、テーブルや数式や書式の設定は手作業でお願いしてもいいのですが面倒かもしれないので １回こっきりの設定マクロも提示予定。
（β） 2015/06/21(日) 08:48
もう１つ、教えてください
現在、一覧表シートはシート保護をかけて使っておられますか？ 一覧表をテーブル設定で使いたいなと思ってまして、でも、シート保護がかかっていれば テーブルの自動拡張機能が働かなくなるので、
・シート保護なしでテーブル利用 ・シート保護で、自前のごりごりロジック
いずれにしようか、悩んでまして。
（β） 2015/06/21(日) 14:31
質問・確認攻めで、大変でしょうし、だんだん心苦しくなってきましたが・・・・
もし、同じ日に、同じ人の伝票が９０（つまり、一覧表では２行）あった場合、この時、貸方や合計も２行あるわけですが 振伝シートでは どのように表示するのがいいのですか？
コードを追いかけたんですが、いまいちわからないので。
そうそう、コードをおいかけて思ったんですが、"全て" で作表する場合、名前のブレークをコードではチェックしていませんよね。 そうすると振伝１ブロックに、違う人のデータがまざってしまってませんか？
（β） 2015/06/21(日) 16:54
検索関数はVLOOKUPしか使ったことがなくて、MATCHだとそんな検索ができるんですね！！
こういうものだと思ってました。
言われてみれば、別にA列の番号じゃなくてセルの番号でいいんですよね。勝手な思い込みでした。
＞＞★固まったようになってしまうのは、何の処理をしているときですか？ 確かにイベントが複数回実行されるコードですけど
それは入力中の話ですね。入力中に固まるのですか？それともダブルクリックをして、"全て" なり "個別" なりを実行した時に 固まるのですか？
固まるのはダブルクリックをして、"全て" なり "個別" なりを実行した時です。
＞＞ >>同一人物でも上の行が84伝票まで入力してない場合は、伝票番号は1行毎に1始まりにしたいです。
よくわからないので、具体例で教えてくれますか？
同一人物で個人用・事務所用の伝票を振るですけど、その場合の伝票番号はそれぞれ分けたいんです。
行を変えて入力してるで、その場合は行毎に1始まりでいいのですが
もし、84以上にデータがある場合85は行が変わりますが、伝票番号は連番にしたいです。
＞＞★ それと、一覧シートＡ列のNo.は全データ通して、１からの連番ですよね？ で、振伝のNo.は人単位で 1からの連番ですよね？
両方ともそのとおりです。
＞＞ If Target.Column = 260 Then Exit Sub
ここのことですが？260列（ＩＺ列）って合計ですよね？
これは削除するのは忘れてましたすいません。
＞＞ >>（BeforeDoubleClick）
★追加で。 B列（日付）ダブルクリック -> 全て は、指定日付のもの全てということだとおもうのですが A列（No.)ダブルクリック -> 個別 は、その行のみということでいいですか
はい。個別は横入力はやはり見づらいので、入力確認のために作りました。全体で確認でもいいのですが
個人を探すのが手間なので。
＞＞>>●色 一覧シートの適用、振伝シートの（L列M列）結合セルです。
了解です。（それにしては検索領域が Cells ですよね？）
結果が間違い無いので気にしてなかったですが、ダメなんですか？
＞＞ 振伝シートは処理のつど、まずからっぽにして、最初からセットしていくと理解しているんですが
それにしては、コードの中で振伝シートのデータ最終行を判定していおるところがありますね？
はい、最終行を判定しかやったことないから疑問に思ったことなかったです。
＞＞★追加で
一覧シート、最大でどれぐらいの行数になる見込みですか？
850行以内には収まる予定です。
＞＞★もう１つ
一覧シートのレイアウトを変更するというのは可能ですか？ たとえば、IYからJAを削除して、貸方、合計、貸方2、合計2 にしてしまうとか。 通常は、貸方、合計 に記載。２段になる場合にのみ 貸方2、合計2 を使うとか。 （振伝順番は使わなくても必要な順番で並び替えはできますので）
IY IZ JA JB
貸方1、合計1、貸方2、合計2 可能です。
＞＞もう１つ、教えてください
現在、一覧表シートはシート保護をかけて使っておられますか？
シートの保護はかけてないです。
方針を読みました。
凄いですね。知らない機能ばかりで、ビックリです。
自分の仕事の効率化をするために独学で初めたので、知識は偏ってますし
知らないことばっかりで恥ずかしい限りです。
この方針でよろしくお願いします。
（くろ） 2015/06/21(日) 17:10
回答が遅くてすいません。
1度書いたものを消してしまって、書き直してました。
＞＞もし、同じ日に、同じ人の伝票が９０（つまり、一覧表では２行）あった場合、この時、貸方や合計も２行あるわけですが
振伝シートでは どのように表示するのがいいのですか？
そうですね、まだ実際には84以上になったことが無いので、そこまで見直せてませんでした。
振伝シートはNo.1に全ての合計を表示したいです。
（くろ） 2015/06/21(日) 17:15
ありがとうございます。
まずは、以上の認識で書いてみます。 要件誤解は多々あるかとは思いますが、それは、都度、つぶしていきましょう。 ただ、コードを書くのに（というか、構想を実装ベースの構成におとしこむのに）少し時間がかかると思います。
（β） 2015/06/21(日) 17:30
とりあえず書いてみました。
コメントしたように、できるだけコード処理を減らすために、テーブルを使っています。 もし、(くろ)さんがテーブルに詳しくなければ、 【エクセル テーブル】や【ＶＢＡ エクセル テーブル】といったもので検索し、わかりやすい解説ページに 目を通しておかれたらよろしいかと思いますが、テーブルを設定することで、新規行をテーブル領域の下の行に入力すれば 自動的にテーブルに加えられ、また、数式や書式なんかもコピーされます。
また、テーブル以外にも、事務所、視点の色がえは条件付き書式で対応、ＩＺ列の合計は数式、振伝シートの各種書式等は、 あらかじめセットしておくことでコード処理から省きました。 ただ、テーブル機能を使うとシートの保護がかけられないので、数式や連番が操作者のうっかりミスで消されてしまうリスクがあります。 なので、やむなし、一覧表のChangeイベントで、数式や連番の復旧をしています。（イベント処理回数はミニマイスしたつもりですが）
また、合計数式は、通常であれば SUMPRODUCT を使う場面かもしれませんが、項目数が多すぎるのか、エラーになりますので ここはユーザー定義関数（SumDebit）を使いました。
ということで、現在のブックの各シートの書式等々を変更してもらわなければいけないのですが、それをお願いすると おそらく、それだけで１週間ぐらいＱ／Ａを重ねることになりそう。 なので、１回こっきりの自動設定マクロを準備しました。 （１回こっきりと書きましたが、何かの障害で、テーブルや書式が壊れたりした場合は 随時、実行することは可能です）
なお、現在のコードはすべて消し去ってもらう必要があります。（ThisWorkbookモジュール、シートモジュール、標準モジュール） その上で、以下。
で、まず、"１回こっきり"を実行してください。これで、テーブル設定等々が行われます。 そのあと、いろいろ試してみてください。
●ThisWorkbookモジュール
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
ReForm一覧
With Sheets("一覧表")
'テーブルの下のＢ列セルを選択
Application.Goto .Cells(.ListObjects(1).ListRows.Count + 2, "B")
End With
Application.EnableEvents = True
End Sub
●一覧表 シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim st As Long
Dim cnt As Long
If Intersect(Target, ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
ReForm一覧
Select Case Target.Column
Case 1
'選択された行のみの振伝作成(個別)
make振伝 Target.Row, 1
Case 2
'選択された日付をもつデータの振伝作成(全て)
st = WorksheetFunction.Match(Target.EntireRow.Range("B1"), Columns("B"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("B"), Target)
make振伝 st, cnt
保存
End Select
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim c As Range
Dim i As Long
'念のため入力あった行の数式とＡ列の連番を再セット
Set r = Intersect(Target, ListObjects(1).DataBodyRange)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each c In r.Rows
i = c.Row
Rows(i).Range("IZ1").Formula = "=SumDebit(F" & i & ":IU" & i & ")-JB" & i
Rows(i).Range("A1").Value = i - 1
Next
Application.EnableEvents = True
End Sub
●リストシート シートモジュール
Private Sub Worksheet_Deactivate()
Application.EnableEvents = False
ReForm一覧
Application.EnableEvents = True
End Sub
●標準モジュール Module1 （１回こっきりは単独モジュールにしておきましょう）
Sub 一回こっきり()
Dim j As Long
Application.EnableEvents = False
With Sheets("一覧表")
.Cells.Borders.LineStyle = xlNone
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
For j = Columns("E").Column To Columns("IT").Column Step 3
With .ListObjects(1).ListColumns(j).Range
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*事務所"")"
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*支店"")"
With .FormatConditions(2).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
End With
Next
With .ListObjects(1)
With .ListColumns(1).Range
.Offset(1).Resize(.Rows.Count - 1).Formula = "=ROW()-1"
.Offset(1).Resize(.Rows.Count - 1).Value = .Offset(1).Resize(.Rows.Count - 1).Value
End With
With .ListColumns(260).Range
.Offset(1).Resize(.Rows.Count - 1).Formula = "=SUMDEBIT(F2:IU2)-JB2"
End With
End With
End With
With Sheets("振伝")
With .Range("A1", .UsedRange)
If .Rows.Count > 14 Then
.Offset(14).EntireRow.Delete
End If
End With
.Range("M2").ClearContents
.Range("B4:K4").ClearContents
.Range("B6:I12").ClearContents
.Range("K6:K12").ClearContents
.Range("L6:M12").ClearContents
.Range("N6:R7").ClearContents
.Range("N13:R13").ClearContents
.Range("S6:Z7").ClearContents
.Range("B4").NumberFormatLocal = "ggge年m月d日"
.Range("B6:B12").NumberFormatLocal = "#,###"
.Range("L6:M12").ShrinkToFit = True
.Range("N2").Font.Size = 10
.Range("S6").NumberFormatLocal = "#,###"
.Range("S7").NumberFormatLocal = "#,###"
With .Range("L1:L12")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*事務所"")"
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*支店"")"
With .FormatConditions(2).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
End With
End With
Application.EnableEvents = True
End Sub
●標準モジュール （Module2）
Function SumDebit(r As Range, Optional intvl = 3) As Variant
Dim i As Long
For i = 1 To r.Count Step intvl
SumDebit = SumDebit + Val(r.Cells(i).Value)
Next
End Function
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldP As String
Dim newP As String
Dim i As Long
Dim j As Long
Dim num As Long
Dim copyFrom As Range
Dim setcnt As Long
Dim crItem1 As String
Dim CrAmt1 As Long
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Set sh1 = Sheets("一覧表")
Set sh2 = Sheets("振伝")
With sh2.Range("A1", sh2.UsedRange)
If .Rows.Count > 14 Then
.Offset(14).EntireRow.Delete
End If
End With
Set copyFrom = sh2.Rows("1:14")
'各行の取り出し
For i = st To st + cnt - 1
If pos Is Nothing Then '最初
Set pos = sh2.Range("A1")
Else
Set pos = pos.Offset(14) '次のブロック位置
copyFrom.Copy pos
Application.CutCopyMode = False
End If
'ブロックの初期化
pos.Range("B6:I12").ClearContents
pos.Range("K6:K12").ClearContents
pos.Range("L6:M12").ClearContents
setcnt = 0
'ヘッダー項目
crItem1 = sh1.Rows(i).Range("IY1").Value
CrAmt1 = sh1.Rows(i).Range("IZ1").Value
crItem2 = sh1.Rows(i).Range("JA1").Value
CrAmt2 = sh1.Rows(i).Range("JB1").Value
dt = sh1.Rows(i).Range("B1").Value
newP = sh1.Rows(i).Range("C1").Value
If newP <> oldP Then num = 0 '名前が変われば連番リセット
num = num + 1
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
pos.Range("N6").Value = crItem1
pos.Range("N7").Value = CrAmt1
pos.Range("S6").Value = crItem2
pos.Range("S7").Value = CrAmt2
'行内の借方項目の取り出し
For j = Columns("D").Column To Columns("IS").Column Step 3
DrItem = sh1.Cells(i, j).Value
If DrItem = "" Then Exit For '借方項目が空白になれば、その行はおしまい
DrRmk = sh1.Cells(i, j + 1).Value
DrAmt = sh1.Cells(i, j + 2).Value
If setcnt = 7 Then '7項目セット済みならブロックを追加
copyFrom.Copy pos.Offset(14)
Application.CutCopyMode = False
Set pos = pos.Offset(14)
num = num + 1
pos.Range("M2").Value = num
pos.Range("N6").Value = Empty
pos.Range("N7").Value = Empty
pos.Range("S6").Value = Empty
pos.Range("S7").Value = Empty
setcnt = 0
End If
setcnt = setcnt + 1
pos.Range("B6").Offset(setcnt - 1).Value = DrAmt
pos.Range("K6").Offset(setcnt - 1).Value = DrItem
pos.Range("L6").Offset(setcnt - 1).Value = DrRmk
Next
oldP = newP
Next
End Sub
Sub 保存()
Dim FileName As String
Dim myDate As Date
Sheets("振伝").Copy
FileName = ThisWorkbook.Path & "\" & Month(myDate) & "月" & ".xlsx"
With ActiveWorkbook
myDate = .Sheets(1).Range("B4")
FileName = ThisWorkbook.Path & "\" & Month(myDate) & "月" & ".xlsx"
.Sheets(1).Name = Month(myDate) & "月"
Application.DisplayAlerts = False '同名ブックあれば無条件上書き
.SaveAs FileName
Application.DisplayAlerts = True
End With
End Sub
Sub 一覧並び替え()
Application.EnableEvents = False
ReForm一覧
Application.EnableEvents = True
End Sub
Sub ReForm一覧()
Dim w As Variant
Application.EnableEvents = False
With Sheets("一覧表").ListObjects(1)
'並び替え
w = WorksheetFunction.Transpose(Sheets("リスト").Range("No").Columns(1).Value)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Columns(2), Order:=xlAscending
.Sort.SortFields.Add Key:=Columns(3), Order:=xlAscending, CustomOrder:=Join(w, ",")
With .Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'連番再作成
.DataBodyRange.Columns(1).Cells(1).Value = 1
.DataBodyRange.Columns(1).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, step:=1, Trend:=False
End With
Application.EnableEvents = True
End Sub
（β） 2015/06/22(月) 09:20
追伸です。
一覧表の並び替えタイミングはダブルクリックによる振伝作成時、ブックの保存時、それとリストシートから戻った時ですが それとは別に、いつでも任意で実行可能です。
その場合、"一覧並び替え" マクロを実行してください。
（β） 2015/06/22(月) 09:22
ありがとうございます。
構文は理解できないので、実行ベースで申し訳ないですが、今現在の不具合です。
★ブックを開くと。
"○○.xlsm"の一部の内容に問題が見つかりました。
可能な限り内容を回復しますか？ブックの発行元が信頼できる場合は、【はい】をクリックして下さい。
はいをクリックする。
削除されたレコード: /xl/tables/table1.xml パーツ内の並べ替え (テーブル)
とでる。
これは私が既に3つテーブルを作ってるのが影響してますか？
リストシートに名前・科目・Noの3つテーブルが存在します。
★一回こっきり
☆貸方の金額を（）で囲みたいので
.Range("S6").NumberFormatLocal = "(#,###)"
.Range("S7").NumberFormatLocal = "(#,###)"
に変更したら、S7に数字がなくても（）がでるのを金額なければ出ないようにしたいです。
☆＊＊事業所と＊＊支店の赤になるタイミングはいつですか？
新しく入力した行に反映されません・
★make振伝
☆全てを出力した場合のデータが違う。
同じ人が複数回でてくる。
☆適用のみ、適用と金額だけを入力する場合がある。
その時のデータが出て無い。（科目は空白）
☆貸方の位置が相違 ''''の箇所
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1 ''''
pos.Range("N7").Value = crItem2 ''''
pos.Range("S7").Value = CrAmt2
★ １社員だけ並び替えの順番と違うとこにでるんですが原因は何ですかね？
（くろ） 2015/06/22(月) 12:47
>>★ブックを開くと。
これは、一回こっきりで処理した後、保存して閉じて、再度、開いたときでしょうか？ こちらでは（もちろん）発生していませんが、ブックが壊れてしまった？ ちょっと悩んでみます。
前にもお聞きしていますが、一覧表の実際のデータ件数は、どれぐらいですか？
**事業所や**支店は入力があれば即座に赤になりますが、テーブル設定がうまくいっていないので 条件付き書式のセットもうまくいっていないのかもしれません。
そのほかの、位置や(#,###)の件は、いつでも直せるので、まずは、ブックが正常に開けないという現象を つぶしましょう。 このマクロブックに以下のコードを書いて実行し、表示されるメッセージを教えてください。 それと、適用列（Ｅ列他）の、どの列のどのセルでもいいので選んで、条件付き書式->ルールの管理で どんな条件が設定されているか、あるいは、設定されていないか調べて教えてください。
（β） 2015/06/22(月) 13:06
テストしてもらうコードを書かないままアップしていました。 以下のマクロで正常にテーブルが作成されていれば、全体の行数と列数が表示されます。 この数字が正しいかどうかのチェックもやってください。
Sub Test()
Dim o As ListObject
On Error Resume Next
Set o = Sheets("一覧表").ListObjects(1)
On Error GoTo 0
If o Is Nothing Then
MsgBox "NG"
Else
MsgBox o.Name & vbLf & o.ListRows.Count + 1 & vbLf & o.ListColumns.Count
End If
End Sub
（β） 2015/06/22(月) 13:10
＞＞これは、一回こっきりで処理した後、保存して閉じて、再度、開いたときでしょうか？
はい、保存して再度立ち上げるとでます。
＞＞前にもお聞きしていますが、一覧表の実際のデータ件数は、どれぐらいですか？
今現在は116行まで入力してます。年度末には850行くらいになる予定です。
＞＞マクロテスト実行
テーブル4
116
262
と表示されました。
お手数ですが、よろしくお願いします。
（くろ） 2015/06/22(月) 13:43
書き忘れました。
＞＞適用列（Ｅ列他）の、どの列のどのセルでもいいので選んで、条件付き書式->ルールの管理で
どんな条件が設定されているか、あるいは、設定されていないか調べて教えてください。
=COUNTIF(E1,"*事務所")
=COUNTIF(E1,"*支店")
です。
（くろ） 2015/06/22(月) 14:05
おもったより小さなデータ量ですね。了解です。
しかし・・・
テーブルはちゃんと設定されているようですし、条件付き書式も設定されているようですね。
たとえば E10（でも、どこでもいいのですが）○支店 とか □□事務所 といれても赤くならないということなんですね？
う〜ん・・・
追加で。
たとえば今、116行目までデータがあるようですが、117行目のＢ列に何か日付をいれると その行がテーブルに加わりますか？それとも無反応ですか？ テーブルに加われば117行目にも罫線がつけられます。
もう１つ。
並び順指定に反映しない名前は具体的にどういう名前ですか？ で、（当然なんですが）売上表の名前と、リストシートの名前は同じですよね？ 田中 と 田 中 は、同じとはみなされませんので。 リストシートにあるNoの領域範囲はどうなっていますか？ で、その反映しない名前は、 もちろん、この領域範囲内にあるのですよね？
もう２つ。
pos.Range("S6").Value = CrAmt1 ''''
pos.Range("N7").Value = crItem2 ''''
え？ 違ってますか？正しくはどこですか？
それと、既存の行のE列の適用欄には、ちゃんと赤が付いてますか？
（β） 2015/06/22(月) 15:23
念のために聞かせてください。
このマクロブックを作成したエクセルのバージョンと、実行してエラー表示されたエクセルのバージョンは 同じでしょうか？
当初のそちらのコード内に、.BorderAround メソッドが記述されていて、これは xl2013 でリリースされた 新しいメソッドで、xl2010までの環境では使えないと理解していまして、なので、そちらの環境はすべて xl2013 だと思っているのですが念のためにお聞きします。
(この回答をもらったとしても、じゃぁ、こうだということではありません。 とにかく手がかりを１つでも集めたくて。ちなみに当方は、xl2013で開発し、xl2010,xl2013 での稼働確認をしています）
（β） 2015/06/22(月) 16:03
＞＞たとえば E10（でも、どこでもいいのですが）○支店 とか □□事務所 といれても赤くならないということなんですね？
どの行でもどの列でも新しく入力したものは赤にはなりません。
＞＞ たとえば今、116行目までデータがあるようですが、117行目のＢ列に何か日付をいれると
その行がテーブルに加わりますか？それとも無反応ですか？ テーブルに加われば117行目にも罫線がつけられます。
テーブルにはなります。罫線もつきます。合計もでます。
＞＞並び順指定に反映しない名前は具体的にどういう名前ですか？
で、（当然なんですが）売上表の名前と、リストシートの名前は同じですよね？
黒田です。
名前と順番の表は違います。名前（Ｂ列）はあいうえお順なので、別に名前を定義してます。
たまに名前の後ろに空白が入ってて認識しない時があったりしましたが、
私が作った振伝順番(ＪＡ列)に番号だしてる時は合ってました。
＞＞分かりにくくすすいません
変更前
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
pos.Range("N6").Value = crItem1
pos.Range("N7").Value = CrAmt1
pos.Range("S6").Value = crItem2
pos.Range("S7").Value = CrAmt2
変更後
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1 ''''
pos.Range("N7").Value = crItem2 ''''
pos.Range("S7").Value = CrAmt2
です。
＞＞それと、既存の行のE列の適用欄には、ちゃんと赤が付いてますか？
既存のデータ（一覧表）は赤文字になってます。
＞＞
エクセル2013を使用してます。
宜しくお願いします。
（くろ） 2015/06/22(月) 16:07
20:02 書式表示パターン訂正
>>どの行でもどの列でも新しく入力したものは赤にはなりません。
そのＥ列（Ｅ１１７とか）を選択して、条件付き書式->ルールの管理 で確認しても なにも条件はセットされていないということでしょうか？
で、現在の状況としては
１．開くときにエラーはでるけど、とにかく開くことはできる。 ２．データ追加すると、テーブルには含まれるようだ。ただし、条件付き書式が有効になっていない。 ３．振伝は、レイアウトの一部ミス等はあるけど、とにかく作成されるようだ。
ただし、
４．>>同じ人が複数回でてくる。
たとえば１行しかかく、借方項目も４つしかないのに（つぃまり１ブロックですむのに）同じブロックが２つ作成されるということですか？
５．借方項目があるかないかの判定を借方項目で行っていました。借方項目になおしましょう。
DrItem = sh1.Cells(i, j).Value
If DrItem = "" Then Exit For '借方項目が空白になれば、その行はおしまい
DrRmk = sh1.Cells(i, j + 1).Value
これを
DrRmk = sh1.Cells(i, j + 1).Value
If DrRmk = "" Then Exit For '借方適用が空白になれば、その行はおしまい
DrItem = sh1.Cells(i, j).Value
このように。
６．() 非表示の件
一回こっきりのなかで、"#,###" をセットしているところ、"(#,###);(-#,###);""""" として、一回こっきりを実行してみてください。
７．振伝レイアウトの貸方項目の位置、了解です。
★ところで、振伝作成そのものは、レスポンス的にいかがですか。 真っ白く固まりそうですか？
★黒田の件、不思議ですねぇ。ちなみにこの黒田は、名前リストの中の順番としては 最初？最後？それとも中ほど？
（β） 2015/06/22(月) 18:27
＞＞そのＥ列（Ｅ１１７とか）を選択して、条件付き書式->ルールの管理 で確認しても
なにも条件はセットされていないということでしょうか？
どの行でもﾙｰﾙがE1を参照してるのはいいんですか？
既存データの書式設定が残ってるだけなのかなと、列の幅も自動調整しないです。
＞＞たとえば１行しかかく、借方項目も４つしかないのに（つぃまり１ブロックですむのに）同じブロックが２つ作成されるということですか？
振伝が２枚目がある場合、前の行の人のデータをひっぱってる。
名前の違う人どうしのデータが入り混じってる感じです。
パターンが色々あってまだ整理できてません。
＞＞★ところで、振伝作成そのものは、レスポンス的にいかがですか。
かなりいい感じです。
＞＞★黒田の件、不思議ですねぇ。ちなみにこの黒田は、名前リストの中の順番としては
最初？最後？それとも中ほど？
後ろの方です。不思議ですよね。
家のエクセルが2010なので、マクロは明日会社で試します。
（くろ） 2015/06/22(月) 20:22
＞＞＞＞たとえば１行しかかく、借方項目も４つしかないのに（つぃまり１ブロックですむのに）同じブロックが２つ作成されるということですか？
振伝が２枚目がある場合、前の行の人のデータをひっぱってる。
名前の違う人どうしのデータが入り混じってる感じです。
パターンが色々あってまだ整理できてません。
補足
前の行の人とは、1行前ではなく、一枚目の人が途中に何回もでてきます。 （くろ） 2015/06/22(月) 20:42
>>どの行でもﾙｰﾙがE1を参照してるのはいいんですか？
はい、ＯＫです。2007以降、条件付書式内の数式の持ち方が変わり、どのセルでもセット領域の最初のセル（Ｅ列ならＥ１）に与えた式が表示されます。
>>列の幅も自動調整しないです。
あ！忘れてました。 後ほど、コード追加連絡します。
>>振伝が２枚目がある場合、前の行の人のデータをひっぱってる。 >>名前の違う人どうしのデータが入り混じってる感じです。 >>パターンが色々あってまだ整理できてません。
>>前の行の人とは、1行前ではなく、一枚目の人が途中に何回もでてきます。
う〜ん？ こちらでもテストしてるんですが・・・ １パターンでもいいので、具体的に、こんな行があって、その下にこんな行があったときに 振伝はこうならなきゃいけないのに、こうなってしまうというのを（しつこいようですが）【具体例】で教えてください。
>>★ところで、振伝作成そのものは、レスポンス的にいかがですか。 >>かなりいい感じです。
ちょっと安心しました。レスポンス悪ければ、もうひとひねりしなきゃと思ってましたので。
>>黒田の件
たとえばリストの黒田を山本なんかにして、一覧表の黒田も山本にして実行するとどうなりますか？
（β） 2015/06/22(月) 21:16
列幅自動調整の件、ReForm一覧の'連番再作成の２行の後、End With の前に
'列幅自動調整
.Range.EntireColumn.AutoFit
これをいれてください。
（β） 2015/06/22(月) 21:26
ところで、そちらで発生している不具合とは異なりますが、こちらで、データ入力したり振伝を作成したり あるいは一回こっきりを実行したりしていると妙な現象が発生します。
テーブルの縞模様含めて、いつでもデザインタブでスタイルを変更できるのですが、急に、縞模様の色や場所が 固定されてしまい、デザイン変更が反映しないという現象です。 （しかも不思議なことに、追加された行の部分にはデザイン変更が適用されます）
これはこれで悩みますねぇ。 （テーブル機能のバグがあるのか、コードで実行している処理とテーブル機能の相性があわないというか整合性がとれないというか）
これについては、こちらで追及します。
（β） 2015/06/22(月) 21:42
↑ 報告した不具合は根が深そうですが、とりあえず
１．一回こっきりの、With Sheets("一覧表") の後、For j = Columns("E").Column To Columns("IT").Column Step 3 の前のコードを
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
このように変更。
２．それとは別に、テーブルのみ再設定する以下のマクロを、一回こっきりのモジュールに追加し おかしくなれば、実行してください。（一回こっきりでもいいのですが、それより軽い）
Sub 一覧復旧()
With Sheets("一覧表")
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
End Sub
（β） 2015/06/22(月) 22:00
マクロは2010に対応してないので、まだ試せてません。
振伝を見直して気付いたのは、２枚目以降がある場合。
その月の１番はじめの社員のﾃﾞｰﾀを２枚目以降入力された後、本来の２枚目が記入されてる？
本来のデータ件数によって、１番目の人のデータはじまりが違うので。
【一覧表】
名前 科目1 適用1 金額1・・・科目7 適用7 金額7 科目8 適用8 金額8 科目9 適用9 金額9
A 運賃 ○○ 100 ・・・運賃 ○○ 200
B 通信費 ○○ 1000・・・通信費 ○○ 2000 通信費 ○○ 3000 通信費 ○○ 4000
C 交際費 ○○ 10 ・・・交際費 ○○ 20 交際費 ○○ 30
【振伝】
No.1
運賃 ○○ 100
・
・
・
運賃 ○○ 200
A
No.1
通信費 ○○ 1000
・
・
・
通信費 ○○ 2000
B
No.2
通信費 ○○ 3000
通信費 ○○ 4000
ここからAのデータ
・
運賃 ○○ 200
A
No.1
交際費 ○○ 10
・
・
・
交際費 ○○ 20
C
No.2
交際費 ○○ 30
ここからAのデータ
・
・
運賃 ○○ 200
A
こんな風になります。
＞＞一回こっきりを実行したりしていると妙な現象が発生します
これは思ってました。テーブルの縞模様の色や場所がおかしくなるので、
質問しようと思ってました。
（くろ） 2015/06/22(月) 22:56
例示深謝
全く同じデータをつくり振伝作成しましたが、こちらでは、振伝が Ａ，Ｂ，Ｃの分（いずれも番号は１）が それぞれ２行、４行、２行、正しく作成されています。
不思議ですねぇ。
（β） 2015/06/22(月) 23:44
並び替えの件は、名前を変更したら上手くいったので、元の名前に戻したら正常になりました。
ふりがなが違ったのが原因みたいです。
マクロ変更試しました。
テーブルの縞模様の色や場所がおかしくなるのは、今のところなくなりましたが、
やはり、立ち上げなおすと同じ症状になります。
文字を赤、列の幅は機能しないです。
振伝は１人分でも同現象です。
２枚目以上がある場合で最後の振伝に空白行がある場合、１枚目の伝表のデータが追加されます。
（くろ） 2015/06/23(火) 10:50
追加です。
文字を赤は分かりました。
事務所ではなくて事業所なんです。
後、赤くなるのは背景ではなくて文字事態がいいのですが、
どこを直せばいいのか分かりません。
よろしくお願いします。
（くろ） 2015/06/23(火) 11:48
追加です。
列幅自動調整はダブルクリック後に実行だったんですね。
入力時に変更するものだと思ってました。
一覧表のChangeに記入したのでこれも解決です。
（くろ） 2015/06/23(火) 14:27
ちょっと外出していてレス遅くなりました。
黒田の件、事業所の赤の件、了解。 列幅自動調整の件、(くろ)さんとしてはChangeイベント処理がお望みということで そこはコードを、そちらで対応されたということですね。 もちろん、それでＯＫですが、以前にお願いしたように、コードは、こちらとそちらを 同じにしておかなければこれから先のやりとりに支障がでてきます。 想像はできますが、
'列幅自動調整
.Range.EntireColumn.AutoFit
★これを、コードのどこに入れたか連絡お願いします。
>>振伝は１人分でも同現象です。 >>２枚目以上がある場合で最後の振伝に空白行がある場合、１枚目の伝表のデータが追加されます。
★最後の振伝に空白行がある場合とは、どういう場合ですか？
>>事務所ではなくて事業所なんです。 >>後、赤くなるのは背景ではなくて文字事態がいいのですが、 >>どこを直せばいいのか分かりません。
コード変更そのものは簡単なのですぐにアップしてもいいのですが、 例の縞々があるとき、固定してしまう現象、テーブルの並び替えに起因しているかもしれません。 （ブックを開く際の障害も、こちらでは発生していませんが、テーブルが壊れていることに起因しているかもしれません。）
アップしたコードでは並び替えを2003までのSortメソッドではなく2007以降のSortオブジェクトで実行してますが 実は、テーブルの並び替えは、通常の範囲の並び替えと、微妙に違っているところがあるのに、βのコードは そこを強引に、通常の範囲の並び替えコードで処理しています。
なので、そのあたりを
・処理前に通常の範囲に戻し ・そのあと、並び替え等を実行し ・最後にテーブル再設定
に変更しょうとして現在、こちらのコードが中途半端に手を入れた状態になっています。
もう１つ、マクロ処理を少なくするために、借方合計をユーザー定義関数で処理していますが これも、こちらでいろいろやっていると、むしろ、実行負荷が増加しているようで、ここを 通常のマクロ処理（もともとそちらでやっておられた方法）に変更しようとしています。
★ということもあって、それらコードが落ち着いたら、まとめてアップします。 しばらく我慢して時間くださいね。 もちろん、そちらで、現行ベースで試行されて、気が付いたことがあれば、どんどん教えてくださいね。
（β） 2015/06/23(火) 17:30
＞＞★これを、コードのどこに入れたか連絡お願いします。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim c As Range
Dim i As Long
'念のため入力あった行の数式とＡ列の連番を再セット
Set r = Intersect(Target, ListObjects(1).DataBodyRange)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each c In r.Rows
i = c.Row
Rows(i).Range("IZ1").Formula = "=SumDebit(F" & i & ":IU" & i & ")-JB" & i
Rows(i).Range("A1").Value = i - 1
Next
'列幅自動調整 ''''''ここに入れました
Sheets("一覧表").ListObjects(1).Range.EntireColumn.AutoFit ''''''
Application.EnableEvents = True
End Sub
＞＞★最後の振伝に空白行がある場合とは、どういう場合ですか？
振伝は7行入力できますが、例えばデータが2行目までで終わる時、残りの5行に1枚目の内容が入力されます。
1枚の振伝にデータがおさまる時は、例えばデータが2行目までで終わる時でも残りの5行は空白のままです。（２枚以上ある時だけ）
お手数ですが、私にはさっぱりで、よろしくお願いします。
（くろ） 2015/06/23(火) 17:52
>>振伝は7行入力できますが、例えばデータが2行目までで終わる時、残りの5行に1枚目の内容が入力されます
こちらでも再現しました。チョンボですね。 再現したので、つぶすのはすぐにできると思います。
で、以下には、まだ、反映していません。
一応、書き直しました。フルセットアップします。（振伝のダブりは未対応） これで、テーブルが壊れたりする現象は回避できるのでは？と思いますが、一度壊れたと思われるそちらのブックは 壊れたままかもしれません。 【一部の内容に問題が見つかりました。】で検索すると、いろいろでてきますが
https://support.microsoft.com/ja-jp/kb/820741/ja
あたりを参考に、一度、ブックを修復するか、あるいは、全く新規に作り直してもらわなければいけないかもしれません。
いずれにしても以下。 なお、
・事務所 -> 事業所 ・背景色 -> 文字色 ・AUtofitをChangeイベントで、変更のあったセルの列に対してのみ。 ・振伝 貸方項目の場所 ・一覧表 １行の終わりの判定 借方項目 -> 適用 ・表示書式 (#,###) の件
については対応しています。
今のところ、あとはブックが壊れている問題と、振伝が、（そちらで）おかしく出力されることが残っています。
●ThisWorkbookモジュール
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
ReForm一覧
With Sheets("一覧表")
'テーブルの下のＢ列セルを選択
Application.Goto .Cells(.ListObjects(1).ListRows.Count + 2, "B")
End With
Application.EnableEvents = True
End Sub
●一覧表 シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim st As Long
Dim cnt As Long
If Intersect(Target, ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
ReForm一覧
Select Case Target.Column
Case 1
'選択された行のみの振伝作成(個別)
make振伝 Target.Row, 1
Case 2
'選択された日付をもつデータの振伝作成(全て)
st = WorksheetFunction.Match(Target.EntireRow.Range("B1"), Columns("B"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("B"), Target)
make振伝 st, cnt
保存
End Select
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim c As Range
Dim i As Long
'念のため入力あった行の数式とＡ列の連番を再セット
Set r = Intersect(Target, ListObjects(1).DataBodyRange)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each c In r.Rows
i = c.Row
Rows(i).Range("IZ1").Value = SumDebit(Range("F" & i & ":IU" & i)) - Range("JB" & i).Value
Rows(i).Range("A1").Value = i - 1
'列幅自動調整
c.EntireColumn.AutoFit
Next
Application.EnableEvents = True
End Sub
●リスト シートモジュール
Private Sub Worksheet_Deactivate()
Application.EnableEvents = False
ReForm一覧
Application.EnableEvents = True
End Sub
●標準モジュール （１）
Function SumDebit(r As Range, Optional intvl = 3) As Variant
Dim i As Long
For i = 1 To r.Cells.Count Step intvl
SumDebit = SumDebit + Val(r.Cells(i).Value)
Next
End Function
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldP As String
Dim newP As String
Dim i As Long
Dim j As Long
Dim num As Long
Dim copyFrom As Range
Dim setcnt As Long
Dim crItem1 As String
Dim CrAmt1 As Long
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Set sh1 = Sheets("一覧表")
Set sh2 = Sheets("振伝")
With sh2.Range("A1", sh2.UsedRange)
If .Rows.Count > 14 Then
.Offset(14).EntireRow.Delete
End If
End With
Set copyFrom = sh2.Rows("1:14")
'各行の取り出し
For i = st To st + cnt - 1
If pos Is Nothing Then '最初
Set pos = sh2.Range("A1")
Else
Set pos = pos.Offset(14) '次のブロック位置
copyFrom.Copy pos
Application.CutCopyMode = False
End If
'ブロックの初期化
pos.Range("B6:I12").ClearContents
pos.Range("K6:K12").ClearContents
pos.Range("L6:M12").ClearContents
setcnt = 0
'ヘッダー項目
crItem1 = sh1.Rows(i).Range("IY1").Value
CrAmt1 = sh1.Rows(i).Range("IZ1").Value
crItem2 = sh1.Rows(i).Range("JA1").Value
CrAmt2 = sh1.Rows(i).Range("JB1").Value
dt = sh1.Rows(i).Range("B1").Value
newP = sh1.Rows(i).Range("C1").Value
If newP <> oldP Then num = 0 '名前が変われば連番リセット
num = num + 1
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1 ''''
pos.Range("N7").Value = crItem2 ''''
pos.Range("S7").Value = CrAmt2
'行内の借方項目の取り出し
For j = Columns("D").Column To Columns("IS").Column Step 3
DrRmk = sh1.Cells(i, j + 1).Value
If DrRmk = "" Then Exit For '借方適用が空白になれば、その行はおしまい
DrItem = sh1.Cells(i, j).Value
DrAmt = sh1.Cells(i, j + 2).Value
If setcnt = 7 Then '7項目セット済みならブロックを追加
copyFrom.Copy pos.Offset(14)
Application.CutCopyMode = False
Set pos = pos.Offset(14)
num = num + 1
pos.Range("M2").Value = num
pos.Range("N6").Value = Empty
pos.Range("N7").Value = Empty
pos.Range("S6").Value = Empty
pos.Range("S7").Value = Empty
setcnt = 0
End If
setcnt = setcnt + 1
pos.Range("B6").Offset(setcnt - 1).Value = DrAmt
pos.Range("K6").Offset(setcnt - 1).Value = DrItem
pos.Range("L6").Offset(setcnt - 1).Value = DrRmk
Next
oldP = newP
Next
End Sub
Sub 保存()
Dim FileName As String
Dim myDate As Date
Sheets("振伝").Copy
FileName = ThisWorkbook.Path & "\" & Month(myDate) & "月" & ".xlsx"
With ActiveWorkbook
myDate = .Sheets(1).Range("B4")
FileName = ThisWorkbook.Path & "\" & Month(myDate) & "月" & ".xlsx"
.Sheets(1).Name = Month(myDate) & "月"
Application.DisplayAlerts = False '同名ブックあれば無条件上書き
.SaveAs FileName
Application.DisplayAlerts = True
End With
End Sub
Sub 一覧並び替え()
Application.EnableEvents = False
ReForm一覧
Application.EnableEvents = True
End Sub
Sub ReForm一覧()
Dim w As Variant
Dim r As Range
Application.EnableEvents = False
With Sheets("一覧表")
'テーブル解除
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
Set r = .UsedRange
'並び替え
w = WorksheetFunction.Transpose(Sheets("リスト").Range("No").Columns(1).Value)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Columns(2), Order:=xlAscending
.Sort.SortFields.Add Key:=Columns(3), Order:=xlAscending, CustomOrder:=CStr(Join(w, ","))
With .Sort
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'テーブル再設定
.ListObjects.Add xlSrcRange, r, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
Application.EnableEvents = True
End Sub
●標準モジュール （２）
Sub 一回こっきり()
Dim j As Long
Dim i As Long
Application.EnableEvents = False
With Sheets("一覧表")
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
With .UsedRange
For j = Columns("E").Column To Columns("IT").Column Step 3
With .Columns(j)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*事業所"")"
With .FormatConditions(1).Font
.Color = 255
End With
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*支店"")"
With .FormatConditions(2).Font
.Color = 255
End With
End With
Next
With .Columns("A")
.Offset(1).Resize(.Rows.Count - 1).Formula = "=ROW()-1"
.Offset(1).Resize(.Rows.Count - 1).Value = .Offset(1).Resize(.Rows.Count - 1).Value
End With
With .Columns("IZ")
For i = 2 To .Rows.Count - 1
.Cells(i).Value = SumDebit(Range(.Cells(i).EntireRow.Range("F1"), .Cells(i).EntireRow.Range("IU2"))) - .Cells(i).EntireRow.Range("JB1").Value
Next
End With
End With
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
End With
With Sheets("振伝")
With .Range("A1", .UsedRange)
If .Rows.Count > 14 Then
.Offset(14).EntireRow.Delete
End If
End With
.Range("M2").ClearContents
.Range("B4:K4").ClearContents
.Range("B6:I12").ClearContents
.Range("K6:K12").ClearContents
.Range("L6:M12").ClearContents
.Range("N6:R7").ClearContents
.Range("N13:R13").ClearContents
.Range("S6:Z7").ClearContents
.Range("B4").NumberFormatLocal = "ggge年m月d日"
.Range("B6:B12").NumberFormatLocal = "(#,###);(-#,###);"""""
.Range("L6:M12").ShrinkToFit = True
.Range("N2").Font.Size = 10
.Range("S6").NumberFormatLocal = "(#,###);(-#,###);"""""
.Range("S7").NumberFormatLocal = "(#,###);(-#,###);"""""
With .Range("L1:L12")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*事業所"")"
With .FormatConditions(1).Font
.Color = 255
End With
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(" & .Cells(1).Address(False, False) & ",""*支店"")"
With .FormatConditions(2).Font
.Color = 255
End With
End With
End With
Application.EnableEvents = True
End Sub
Sub 一覧復旧()
With Sheets("一覧表")
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
End Sub
（β） 2015/06/23(火) 18:43
振伝トラブルわかりました。 次のブロックを準備する際に、上のブロックをコピーしているんですが領域の初期化が不足していました。 お恥ずかしい状況。(汗）
make振伝 を以下でリプレース願います。
あと、↑でアップした一回こっきりを流して保存し、再度開いて、エラーが出るかどうか、確認願います。 （条件付き書式のセットもありますので、１回こっきりは、必ず実行しておいてくださいね）
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldP As String
Dim newP As String
Dim i As Long
Dim j As Long
Dim num As Long
Dim copyFrom As Range
Dim setcnt As Long
Dim crItem1 As String
Dim CrAmt1 As Long
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Set sh1 = Sheets("一覧表")
Set sh2 = Sheets("振伝")
With sh2.Range("A1", sh2.UsedRange)
If .Rows.Count > 14 Then
.Offset(14).EntireRow.Delete
End If
End With
Set copyFrom = sh2.Rows("1:14")
'各行の取り出し
For i = st To st + cnt - 1
If pos Is Nothing Then '最初
Set pos = sh2.Range("A1")
Else
Set pos = pos.Offset(14) '次のブロック位置
copyFrom.Copy pos
Application.CutCopyMode = False
End If
'ブロックの初期化
pos.Range("B6:I12").ClearContents
pos.Range("K6:K12").ClearContents
pos.Range("L6:M12").ClearContents
setcnt = 0
'ヘッダー項目
crItem1 = sh1.Rows(i).Range("IY1").Value
CrAmt1 = sh1.Rows(i).Range("IZ1").Value
crItem2 = sh1.Rows(i).Range("JA1").Value
CrAmt2 = sh1.Rows(i).Range("JB1").Value
dt = sh1.Rows(i).Range("B1").Value
newP = sh1.Rows(i).Range("C1").Value
If newP <> oldP Then num = 0 '名前が変われば連番リセット
num = num + 1
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1 ''''
pos.Range("N7").Value = crItem2 ''''
pos.Range("S7").Value = CrAmt2
'行内の借方項目の取り出し
For j = Columns("D").Column To Columns("IS").Column Step 3
DrRmk = sh1.Cells(i, j + 1).Value
If DrRmk = "" Then Exit For '借方適用が空白になれば、その行はおしまい
DrItem = sh1.Cells(i, j).Value
DrAmt = sh1.Cells(i, j + 2).Value
If setcnt = 7 Then '7項目セット済みならブロックを追加
copyFrom.Copy pos.Offset(14)
Application.CutCopyMode = False
Set pos = pos.Offset(14)
num = num + 1
'ブロックの初期化
pos.Range("M2").Value = num
pos.Range("B6:I12").ClearContents
pos.Range("K6:K12").ClearContents
pos.Range("L6:M12").ClearContents
pos.Range("N6").Value = Empty
pos.Range("N7").Value = Empty
pos.Range("S6").Value = Empty
pos.Range("S7").Value = Empty
setcnt = 0
End If
setcnt = setcnt + 1
pos.Range("B6").Offset(setcnt - 1).Value = DrAmt
pos.Range("K6").Offset(setcnt - 1).Value = DrItem
pos.Range("L6").Offset(setcnt - 1).Value = DrRmk
Next
oldP = newP
Next
End Sub
（β） 2015/06/23(火) 18:56
ありがとうございます。
もう会社を出たので明日確認して返事します。
ブックは当初わたしが作ったものを保存してるので、そのブックで作成してみます。
（くろ） 2015/06/23(火) 19:32
はい。確認をお待ちします。
ところで、ReForm一覧ですが
・テーブルを解除して ・通常範囲に対する処理をして ・テーブル再設定
にしています。実は、長年、日常的に使っていく処理で毎回（振伝作成や保存時）これをやるのがいいことなのかどうか、 いまいち、自信というか確信はありません。
テーブルはテーブルのままにして、並び替え含めて、テーブル相手にふさわしいコードにして 毎回の解除、再設定は行わないほうが、いいのかも・・・と思ったりします。
いずれにしてもテーブルが壊れれば、一回こっきり（書式の再設定も含む）や、一覧復旧（テーブル再設定のみ）を実行すれば 回復するとは思いますが。
以下、テーブルはテーブルのままにして解除、再設定を行わない方式です。 そちらで、使っていくうちに、アップ済みの方法で具合がわるくなったときに、入れ替えて使っていただくのも いいかもしれないと思い、参考までに。
Sub ReForm一覧()
Dim w As Variant
Dim r As Range
Dim tblName As String
Dim strB As String
Dim strC As String
Application.EnableEvents = False
With Sheets("一覧表")
strB = .Range("B1").Value
strC = .Range("C1").Value
'並び替え
w = WorksheetFunction.Transpose(Sheets("リスト").Range("No").Columns(1).Value)
.ListObjects(1).Sort.SortFields.Clear
.ListObjects(1).Sort.SortFields.Add Key:=.Range(.ListObjects(1).Name & "[" & strB & "]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.ListObjects(1).Sort.SortFields.Add Key:=.Range(.ListObjects(1).Name & "[" & strC & "]"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CStr(Join(w, ",")), DataOption:=xlSortNormal
With .ListObjects(1).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'連番再設定
.Range("A2").Value = 1
.ListObjects(1).DataBodyRange.Columns(1).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
Application.EnableEvents = True
End Sub
（β） 2015/06/24(水) 09:56
やはりテーブルがおかしくなります。
私が作ったブックを手動でﾃｰﾌﾞﾙにしてみましたが、何の問題もありません。
何が原因何ですかね？
実行時エラー9
インデックスが有効範囲にありません
とでるようになりました。
ReForm一覧は（β） 2015/06/24(水) 09:56の方を採用してます。
【変更箇所】
★一回こっきり()
Sheets("振伝")
.Range("B4").NumberFormatLocal = "ggge年m月d日"
.Range("B6:B12").NumberFormatLocal = "#,###" '''''ここは（）不要
.Range("L6:M12").ShrinkToFit = True
.Range("N13").Font.Size = 10 '''''N2→Ｎ13に変更
.Range("S6").NumberFormatLocal = "(#,###);(-#,###);"""""
.Range("S7").NumberFormatLocal = "(#,###);(-#,###);"""""
★Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim st As Long
Dim cnt As Long
If Intersect(Target, ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
Select Case Target.Column
Case 1
'選択された行のみの振伝作成(個別)
make振伝 Target.Row, 1
Worksheets("振伝").Select ''''''ここ追加
Case 2
'選択された日付をもつデータの振伝作成(全て)
st = WorksheetFunction.Match(Target.EntireRow.Range("B1"), Columns("B"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("B"), Target)
make振伝 st, cnt
保存
End Select
ReForm一覧 '''''クリックをして先に並び変わると、違うデータが出力される
Application.EnableEvents = True
End Sub
【修正して欲しい箇所】
★行が違う同一人物のＮｏが連番になってるのを、それぞれ1から。
★一覧シートの合計（ＩＺ列）がところどころ計算があってない。
★Ｂ列でダブルクリックした場合、振伝が複数枚でる人の２枚目以降の名前が違う。
出力したデータの１番目の人の名前になってる。
★一覧シートのデータが８４を超える時、振伝のNo.13の金額はNo.1に合計で出したい。
（くろ） 2015/06/24(水) 11:18
＞＞実行時エラー9
インデックスが有効範囲にありません
とでるようになりました。
の原因は分かりました。
一覧シートの（BeforeDoubleClick）
ReForm一覧の位置を変更した為です。
個別の実行時に動くのは都合が悪いのですが、どこに持っていけばいいですか？
（くろ） 2015/06/24(水) 11:28
＞＞★一覧シートの合計（ＩＺ列）がところどころ計算があってない。
自己解決しました。
ＩＹ列が通貨になってて、標準に変更したら直りました。
（くろ） 2015/06/24(水) 11:54
追加しました。
★一回こっきり()
Sheets("一覧表")
With .Columns("IZ")
For i = 2 To .Rows.Count - 1
.Cells(i).Value = SumDebit(Range(.Cells(i).EntireRow.Range("F1"), .Cells(i).EntireRow.Range("IU2"))) - .Cells(i).EntireRow.Range("JB1").Value
Next
End With
For j = 6 To 255 Step 3 ''''''ここに追加
.Cells(2, j).NumberFormatLocal = "#,###"
Next
.Range("IZ2").NumberFormatLocal = "#,###" ''''''ここに追加
.Range("JB2").NumberFormatLocal = "#,###" ''''''ここに追加
.Range("B2").NumberFormatLocal = "m月d日" ''''''ここに追加
End With
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.ListObjects(1).ShowAutoFilterDropDown = False
（くろ） 2015/06/24(水) 15:47
>>一覧シートの（BeforeDoubleClick） >>ReForm一覧の位置を変更した為です。 >>個別の実行時に動くのは都合が悪いのですが、どこに持っていけばいいですか？
変更したBeforDoubleClickをアップしてください。
（β） 2015/06/24(水) 15:53
＞＞変更したBeforDoubleClickをアップしてください。
★Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim st As Long
Dim cnt As Long
If Intersect(Target, ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
Select Case Target.Column
Case 1
'選択された行のみの振伝作成(個別)
make振伝 Target.Row, 1
Worksheets("振伝").Select ''''''ここ追加
Case 2
'選択された日付をもつデータの振伝作成(全て)
st = WorksheetFunction.Match(Target.EntireRow.Range("B1"), Columns("B"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("B"), Target)
make振伝 st, cnt
保存
End Select
ReForm一覧 ''''' ここに移動しました。
Application.EnableEvents = True
End Sub
（くろ） 2015/06/24(水) 16:50
To （通りすがりの超トーシロー）さん
そう思います。
To (くろ)さん
表題に No.2 をつけて、新規トピとして立ててください。そこで継続しましょう。
（β） 2015/06/24(水) 17:53
アドバイスありがとうございます。
（くろ） 2015/06/24(水) 21:08
分かりました。
よろしくお願いします。
（くろ） 2015/06/24(水) 21:09
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.