[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データを横から縦にした時の転記』（くろ）
以前ご教授いただいたものを変更したいのでよろしくお願いします。
借方/適用/金額を横に入力していたものを縦に変更しました。
転記先の振伝は変更なしです。
現在自分で変更したのは一回こっきりと標準モジュール1だけです。
標準モジュール1のmake振伝でループが止めたかたが分からず困ってます。
一覧表のＡ列をダブルクリックするとＡ列の数字が同じものだけ転記
一覧表のＢ列をダブルクリックするとＢ列の日付が同じものだけ転記
【旧一覧表】
A____B____C____D____E ____F ・・・ IS_____IT_____IU_____IV_____IW_____IX_____IY_____IZ_____JA_____JB_____JC 1 NO 日付 名前 借方1 適用1 金額1 ・・・借方84 適用84 金額84 空白 空白 空白 貸方1 合計1 貸方2 合計2 振伝順番
（新一覧表）
A_____B_____C_____D_____E _____F_____G______H______I______J_____K_______L 1 No 日付 名前 借方 適用 金額 貸方1 合計1 貸方2 合計2 振伝順番 事務所
【振伝】
1行目〜14行目までが1ブロック
1（M2） 伝票No 2（B4〜K4の10セル） 日付 3（B6〜I6の8セル）〜（B12〜I12の8セル） 金額 4（K6） 〜（K12） 借方 5（L6〜M6の2セル）〜（L12〜M12の2セル） 適用 6（N6〜R6の5セル） 貸方 7（S6〜Z6の8セル） 合計 8（N7〜R7の5セル） 貸方 9（S7〜Z7の8セル） 合計 10（N13〜R13の5セル） 名前 ※（）が1セル（結合）
【旧標準モジュール 1】
Option Explicit
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
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("N13").Value = newP
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
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 r As Range
Dim c As Range
Dim x As Long
Application.EnableEvents = False
With Sheets("一覧表")
'テーブル解除
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
Set r = .UsedRange
'振伝順番リセット
With CreateObject("Scripting.Dictionary")
For Each c In Sheets("リスト").Range("No").Columns(1).Cells
x = x + 1
.Item(c.Value) = x
Next
For Each c In r.Columns("C").Offset(1).Resize(r.Rows.Count - 1).Cells
c.EntireRow.Columns("JC").Value = .Item(c.Value)
Next
End With
'並び替え
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Columns("B"), Order:=xlAscending
.Sort.SortFields.Add Key:=Columns("JC"), Order:=xlAscending
With .Sort
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'テーブル再設定
.ListObjects.Add xlSrcRange, r, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
Application.EnableEvents = True
End Sub
【旧標準モジュール 2】
Option Explicit
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
With .Columns(j + 1) '借方金額欄
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "#,###"
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("B")
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "m月d日"
End With
With .Columns("IZ")
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "#,###"
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"
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("N13").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"
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
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
Select Case Target.Column
Case 1
'選択された行のみの振伝作成(個別)
make振伝 Target.Row, 1
Worksheets("振伝").Select
Case 2
'選択された日付をもつデータの振伝作成(全て)
ReForm一覧
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
【旧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
（新標準モジュール 1）
Option Explicit
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 String
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")
Stop
'各行の取り出し
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("G1").Value
'CrAmt1 = sh1.Rows(i).Range("H1").Value
' crItem2 = sh1.Rows(i).Range("I1").Value
'CrAmt2 = sh1.Rows(i).Range("J1").Value
dt = sh1.Rows(i).Range("B1").Value
newP = sh1.Rows(i).Range("C1").Value
num = 1
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = newP
'行内の借方項目の取り出し
j = 5
Do While Cells(i, 1).Value = Cells(i + 1, 1).Value
'For j = Columns("D").Column To Columns("LF").Column Step 3
DrRmk = sh1.Cells(i, j).Value
' If DrRmk = "" Then Exit For '借方適用が空白になれば、その行はおしまい
DrItem = sh1.Cells(i, j - 1).Value
DrAmt = sh1.Cells(i, j + 1).Value
crItem1 = sh1.Cells(i, j + 2).Value
CrAmt1 = sh1.Cells(i, j + 3).Value
crItem2 = sh1.Cells(i, j + 4).Value
CrAmt2 = sh1.Cells(i, j + 5).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("N13").Value = newP
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
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1
pos.Range("N7").Value = crItem2
pos.Range("S7").Value = CrAmt2
'Next
i = i + 1
Loop
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 r As Range
Dim c As Range
Dim x As Long
Application.EnableEvents = False
With Sheets("一覧表")
'テーブル解除
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
Set r = .UsedRange
'振伝順番リセット
'With CreateObject("Scripting.Dictionary")
'For Each c In Sheets("リスト").Range("No").Columns(1).Cells
' x = x + 1
'.Item(c.Value) = x
'Next
'For Each c In r.Columns("C").Offset(1).Resize(r.Rows.Count - 1).Cells
' c.EntireRow.Columns("K").Value = .Item(c.Value)
'Next
'End With
'並び替え
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Columns("B"), Order:=xlAscending
.Sort.SortFields.Add Key:=Columns("K"), Order:=xlAscending
With .Sort
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'テーブル再設定
.ListObjects.Add xlSrcRange, r, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
Application.EnableEvents = True
End Sub
（新標準モジュール 2）
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
With .Columns("E")
.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
.Range("B:J").EntireColumn.AutoFit
With .Columns("F")
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "#,###"
End With
With .Columns("J")
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "#,###"
End With
With .Columns("A")
.Offset(1).Value = "=ROW(C2)-1"
.Offset(2).Resize(.Rows.Count - 1).Formula = "=IF(CONCATENATE(C3,L3)=CONCATENATE(C2,L2),A2,A2+1)"
End With
With .Columns("K")
.Offset(1).Resize(.Rows.Count - 1).Formula = "=VLOOKUP(C2,テーブル1[[名前]:[振伝順番]],2,FALSE)" '振伝順番
End With
'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("B")
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "m月d日"
End With
With .Columns("H")
.Offset(1).Resize(.Rows.Count - 1).NumberFormatLocal = "#,###"
.Offset(1).Resize(.Rows.Count - 1).Value = "=IF(A2<>A3,SUMIF(A$2:A2,A2,F$2)-SUMIF(A$2:A2,A2,J$2),"""")"
'For i = 2 To .Rows.Count - 1
' .Cells(i).Value = SumDebit(Range(.Cells(i).EntireRow.Range("F1"), .Cells(i).EntireRow.Range("LF1"))) - .Cells(i).EntireRow.Range("LM1").Value '''''
'Next
End With
End With
.ListObjects.Add xlSrcRange, .UsedRange, , xlYes
.ListObjects(1).TableStyle = "TableStyleLight15"
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("N13").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"
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.ColorIndex = xlNone
End With
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
以前になかったＬ列の事業所はＡ列の番号を振るのにあたらしく増えました。
日付や名前が同じでも１番から番号を振りたいのでその場合に文字を入れる事にしました。
現在1500行までデータがあり、最終的に6000行ぐらいなる予定です。
（くろ） 2015/07/11(土) 10:48
私がリンクを貼るのもいかがかと思いますが一応関連トピのリンクです。
[[20150618141702]] 『処理速度を早く、軽くしたい。』（くろ）
[[20150624210958]] 『処理速度を早く、軽くしたい。No.2』（くろ）
（β） 2015/07/11(土) 11:00
レイアウトに関しては入力しやすいもの（前トピで推奨したリスト伝票に近いもの）になったと思います。 着手の前に、いくつか質問・確認です。
・コードの現状
新レイアウト対応のため、そちらで手をいれられたと思います（まだ、コードを読むというところまでいっていません）
１．ある程度、動かして、そちらの思惑が実現している。あとは、目的のデータを縦の行から抽出できればＯＫ というレベルですか？ ２．それにしては、一覧表上で、行追加、あるいは既存の行に変更を加えた際に IZ列に自動計算結果が記入されませんか？ あるいは、リストシートを開き、一覧表シートに戻った時（Reform一覧が自動実行されるわけですが） テーブルそのものが、IZ列まで拡大してしまいませんか？ ２．Reform一覧で、振伝番号が再セットされるべきなんですが、コメントアウトされていますね？ もはや、名前の優先順はなくなったということですか？ ３．それにしては、並び替えでは、この振伝順番をキーにしていますね？ 一方、追加された事業所列にたいしては並び替えキーにしていませんね？なぜですか？
・仕様・要件
４．従来（旧振伝。以降、この呼称にします）は、同じ日の同じ人であっても、行がかわれば、振伝番号は １ から採番されましたね。 新振伝では、行がどこで変わったかわからない、なので、その判定基準として、事業所が同じなら旧振伝の１行に相当。 事業所がかわれば、旧振伝の行がかわった状態。 このような仕様ですね？ ５．旧振伝では A列ダブルクリックは、当該行のみが対象でしたが、新振伝では、その行と同じ人、同じ日付、同じ事業所をもつ 複数行が対象ということですね？ ６．貸方項目について教えてください。 旧振伝では、当該行の借方合計だったわけですが、新振伝では、この列の扱いはどうなっていますか？ １行毎の数字（つまり、借方と同じ数字）ですか？ それとも、先頭ないしは最後の行に、旧振伝の貸方と同じような内容で記載されるのですか？
（β） 2015/07/11(土) 17:13
いったん、以下に追加提案をしましたが、まずは、今出ている要件をやっつけましょう。 なので、以下に記載した追加提案は、いったん消します。
（β） 2015/07/11(土) 18:08
いつもお世話になってます。
・コードの現状
＞＞１．ある程度、動かして、そちらの思惑が実現している。あとは、目的のデータを縦の行から抽出できればＯＫ というレベルですか？
まだそこまでにレベルではなく、イメージでこうやったらできるかもと一覧表のレイアウトを変えて、振伝の転記の仕方を考えてるところで上手くいかず相談にいたりました。
＞＞２．それにしては、一覧表上で、行追加、あるいは既存の行に変更を加えた際に IZ列に自動計算結果が記入されませんか？
IZ列とは旧のものですよね？わたしは追加してないですけど、何のことでしょうか？
あるいは、リストシートを開き、一覧表シートに戻った時（Reform一覧が自動実行されるわけですが） テーブルそのものが、IZ列まで拡大してしまいませんか？
テーブルはJC列まででした。
＞＞２．Reform一覧で、振伝番号が再セットされるべきなんですが、コメントアウトされていますね？
もはや、名前の優先順はなくなったということですか？
日付と振伝順番での並び替えは必要です。縦にデータを変更した時にあまりに時間がかかるので、 一回こっきりに入れました。（これで上手くいけばと試作段階なのですが）
＞＞３．それにしては、並び替えでは、この振伝順番をキーにしていますね？
一方、追加された事業所列にたいしては並び替えキーにしていませんね？なぜですか？
まだそこまで試せてなくて。すいません。
入力時に連番にしたい部分は連続して入力しているので想定してませんでした。
でももちろん後日追加もあるのでいわれてみて必要だということがわかりました。
・仕様・要件
＞＞４．従来（旧振伝。以降、この呼称にします）は、同じ日の同じ人であっても、行がかわれば、振伝番号は １ から採番されましたね。
新振伝では、行がどこで変わったかわからない、なので、その判定基準として、事業所が同じなら旧振伝の１行に相当。 事業所がかわれば、旧振伝の行がかわった状態。このような仕様ですね？
はい、そのとおりです。ただ、事業所名がなく空欄の場合もあります。
＞＞５．旧振伝では A列ダブルクリックは、当該行のみが対象でしたが、新振伝では、その行と同じ人、同じ日付、同じ事業所をもつ 複数行が対象ということですね？
はい、そのとおりです。なのでわたしが考えたのは同じ数字をふるというものでした。
＞＞６．貸方項目について教えてください。
旧振伝では、当該行の借方合計だったわけですが、新振伝では、この列の扱いはどうなっていますか？ １行毎の数字（つまり、借方と同じ数字）ですか？ それとも、先頭ないしは最後の行に、旧振伝の貸方と同じような内容で記載されるのですか？
J列（合計2）、H列（合計1）の最終行に合計が出るようになってます。
H=IF(A2<>A3,SUMIF(A$2:A2,A2,F$2)-SUMIF(A$2:A2,A2,J$2),"")
よろしくお願いします。
（くろ） 2015/07/12(日) 13:16
>>IZ列とは旧のものですよね？わたしは追加してないですけど、何のことでしょうか？
一覧表シートモジュールの Changeイベントで書きこんでいます。
>>日付と振伝順番での並び替えは必要です。縦にデータを変更した時にあまりに時間がかかるので、 >>一回こっきりに入れました。（これで上手くいけばと試作段階なのですが）
一回こっきりは、名前の通り、「一回こっきり」で、本来は、最初に手作業で式や書式やテーブルの設定をすればいいのですが 面倒かもしれないと思い、手作業の代わりに準備しただけのものです。
で、実際のデータ入力では使われませんので、新規に追加した行の振伝順番が空白のままになりますね？ また、仮に名前を変更した時には、変更しなければいけませんよね？
ここは振り直し必須ですが、並び替えは並び替えでやらなければいけないわけで、並び替えキーが１つ増えたから遅くなるということは まず、考えられません。 振伝順番の設定にもそんなに時間がかかるとは思えません。
具体的に、どんな時に、どれぐらいおそかったですか？
>>事業所名がなく空欄の場合もあります。
空白という値の事業所だと思えばいいですね。 つまり、同じ名前で２行続いていて、ともに事業所が空欄なら、この２行は同じ事業所、つまり、旧振伝の、同じ１行ということですね。
>>なのでわたしが考えたのは同じ数字をふるというものでした。
A列の連番のことですか？ これは、そうしなくてもOKですし、逆に同じものでグルーピングして振りなおすほうが ロジックは面倒になりますよ。 旧振伝同様、新振伝でも一覧表A列は、ただのかざり（？）として考えておきましょう。
>>J列（合計2）、H列（合計1）の最終行に合計が出るようになってます。 >>H=IF(A2<>A3,SUMIF(A$2:A2,A2,F$2)-SUMIF(A$2:A2,A2,J$2),"")
なるほど、了解です。 ただ、A列をただにかざりと考えていますので、う〜ん・・・ ちょっと考えてみます。
このレスで、いくつか質問していることの回答はいただきたいのですが、それはそれとして 新振伝としての処理方式の構成を、考えはじめます。
（β） 2015/07/12(日) 19:24
ちなみに、J列にはどんな式を入れようとしています？ というか、貸方２合計は、旧振伝では入力項目でしたね。 今回式をいれるとすると、貸方合計も貸方２合計も式？？ 貸方２の金額はどうやってしていする予定ですか？
（β） 2015/07/12(日) 19:57
＞＞一覧表シートモジュールの Changeイベントで書きこんでいます。
Rows(i).Range("IZ1").Value = SumDebit(Range("F" & i & ":IU" & i)) - Range("JB" & i).Value
この部分ですか？私は書いてないです。（β） さんの作ったままです。
＞＞ で、実際のデータ入力では使われませんので、新規に追加した行の振伝順番が空白のままになりますね？また、仮に名前を変更した時には、変更しなければいけませんよね？
そう思って関数にしたのですがダメなんですかね？
With .Columns("K")
.Offset(1).Resize(.Rows.Count - 1).Formula = "=VLOOKUP(C2,テーブル1[[名前]:[振伝順番]],2,FALSE)" '振伝順番
End With
＞＞ここは振り直し必須ですが、並び替えは並び替えでやらなければいけないわけで、並び替えキーが１つ増えたから遅くなるということは
まず、考えられません。 振伝順番の設定にもそんなに時間がかかるとは思えません。 具体的に、どんな時に、どれぐらいおそかったですか？
Reform一覧が動く時です、リストシートから他のシートへ行った時や、保存のときです。
以前の横にデータの時は思わなかったんですが、ちょっと待つ感じなので変更してみたら
早くなったので。
ちなみにリストシートは名前の名義以外にも一覧表を入力するのに必要な特記事項が書いてあり
かなりの頻度でみるので、
Private Sub Worksheet_Deactivate()
Application.EnableEvents = False
ReForm一覧
Application.EnableEvents = True
End Sub
この部分は止めてます。
保存の時と、B列のダブルクリックの時で十分です。
＞＞空白という値の事業所だと思えばいいですね。
つまり、同じ名前で２行続いていて、ともに事業所が空欄なら、この２行は同じ事業所、つまり、旧振伝の、同じ１行ということですね。
はいそのとおりです。
＞＞A列の連番のことですか？ これは、そうしなくてもOKですし、逆に同じものでグルーピングして振りなおすほうが
ロジックは面倒になりますよ。 旧振伝同様、新振伝でも一覧表A列は、ただのかざり（？）として考えておきましょう。
なるほど、了解です。
ただ、A列をただにかざりと考えていますので、う〜ん・・・ ちょっと考えてみます。
A列はかざりで対応できるのならそれでお願いします。
私にはそれ以外思いつかなかっただけなので。
＞＞ちなみに、J列にはどんな式を入れようとしています？
書き方が悪くてすいません。
Ｊ列は入力項目です。
式（H=IF(A2<>A3,SUMIF(A$2:A2,A2,F$2)-SUMIF(A$2:A2,A2,J$2),"") ）はＨ列のみです。
（くろ） 2015/07/12(日) 21:05
>>私は書いてないです。（β） さんの作ったままです。
そうですよ。でも、他の部分もβが書いたものを、(くろ)さんが新振伝に合わせて手を入れたんですよね。 で、ここは(くろ)さんが手を入れていなかったので指摘したんです。
>>.Offset(1).Resize(.Rows.Count - 1).Formula = "=VLOOKUP(C2,テーブル1[[名前]:[振伝順番]],2,FALSE)" '振伝順番
一回こっきりのコードは見ていなかったので。確かにありましたね。 ところで、テーブル1。これは、どのシートのテーブル名ですか？リストシートですか？一覧シートですか？ リストシートだとしたら、そこにテーブルを設定したんですか？（こちらでは旧振伝のままなのでリストシートにはテーブル設定していません） で、そちらでは、これでうまくいってますか？
まぁ、ここに式を入れておくというのは悪くはないと思いますが。
>>ちなみにリストシートは名前の名義以外にも一覧表を入力するのに必要な特記事項が書いてあり >>かなりの頻度でみるので、・・・・ >>この部分は止めてます。 >>保存の時と、B列のダブルクリックの時で十分です。
見ただけで戻った時には、動かないようにしようと考えていたんですが、一覧表K列に式がうまくはいれば Deactivateを取り除いてもいいかもしれませんね。
ただ・・・
>>現在自分で変更したのは一回こっきりと標準モジュール1だけです。
と書いてあったので、WorkbookモジュールやSheetモジュールは変更がないのかなと思ってました。 そのあたりは、双方のバージョンをあわせるためにも、正確に連絡してくださいね。
それと
>>B列のダブルクリックの時で十分です。
旧振伝は A列ダブルクリック時はreform一覧は確かに必要なかったんですが、こんどは 旧振伝の１行が複数行になってますよね。 ケースとしては、このブロックに、行追加した。で、それは一覧表のテーブルの一番下にある。 なので、新振伝では A列ダブルクリック時にも並び替えが必要になりますよ。
>>Ｊ列は入力項目です。
了解。ただし、すでに３行ほど入っていて、式で３行目の貸方合計が表示されている。 入力者は、ここに（必要であれば）貸方合計２を入力するんでしょうね。 で、もし、データ１行を追加した時、振伝作成時、それが並び替えられて、この４行目になると思いますが、 その時は、貸方合計は４行目、貸方２合計は３行目という状況になりますね。 まぁ、そういう状況がありうるということでコードを考えればいいんですけどね。
じっくり考えますが、大変そう・・・・
究極は、「本当のリスト伝票形式の入力」を提案しなきゃいけなくなるかもしれません。 まぁ、それは、出たとこ勝負で。
（β） 2015/07/12(日) 21:39
全体の新しい処理の流れ、構想的には70%ぐらいは固まってきました。 それはさておき、ちょっと、中間報告というか、情報共有的に。
１．旧振伝では テーブル解除->並び替え等->テーブル再設定 このような処理をしていました。 理由は、当初の、テーブルハンドリングで、そちらで発生したトラブル、結局は原因は、並び替えユーザー設定リストの文字数の問題でしたが それがわからず、テーブルがゆえの何かがあるんだろうということで、そのようにしたわけですが、結局は、その必要はなく テーブルのまま、テーブル用の並び替えを行ってもＯＫでした。 ２．もう１つ、旧振伝で、当初、貸方金額計算をユーザー定義関数SumDebitをシート上に記載していたんですが、テーブル解除、テーブル再設定のたびに 全体が再計算され、処理効率の足を引っ張りましたので、これを、マクロ内での計算に変更した経緯があります。 ３．今回、振伝順番他、シート上の計算式が増えるようですが、そうすると、この並び替えのたびのシート全体の再計算（しかも解除と再設定の２回）が 発生することになります。 ４．なので、（↑の１．はテーブルが原因ではなかったわけですから）新振伝では、テーブル解除->並び替え等->テーブル再設定ではなく テーブルとしての並び替えを行うように変更する予定です。
もう１つ。
たとえば、そちらで手を入れた一回こっきりに
>>.Offset(1).Resize(.Rows.Count - 1).Formula = "=VLOOKUP(C2,テーブル1[[名前]:[振伝順番]],2,FALSE)" '振伝順番
こういうところがありますよね。この中の テーブル1 は、（おそらくリストシートの）テーブル名なんですが、これは、仮に解除して再設定すると 別の番号が振られます。テーブル名はブックを通して管理されますので、たとえば テーブル5 といったように。 そうすると、このコードは、実行時エラーになってしまいます。
回避策は
Ａ．旧振伝でβのコードがやっていたように、そのテーブル名を取得して、コードの中のテーブル名に、それを変数で与える。 Ｂ．テーブル名を、システムデフォルトのテーブル○ではなく、たとえば "顧客リスト" とか "一覧表" という固定の名前にする。 これは必要であればコード実行時にもできますが、操作で、テーブル○と割り振られたテーブルのテーブル名の名前ボックスで 変更もできます。 （新振伝では、テーブル解除、再設定は行わない予定ですが、一回こっきりなどでテーブルを再作成した際には名前がかわりますので要注意）
（β） 2015/07/13(月) 05:53
＞＞そうですよ。でも、他の部分もβが書いたものを、(くろ)さんが新振伝に合わせて手を入れたんですよね。で、ここは(くろ)さんが手を入れていなかったので指摘したんです。
すいません、現在自分で変更したのは一回こっきりと標準モジュール1だけです。と書いた意味は
まだこの部分以外は変更出来てないということを伝えたつもりでした。
なのでまだ、手つかずでした。
＞＞リストシートだとしたら、そこにテーブルを設定したんですか？（こちらでは旧振伝のままなのでリストシートにはテーブル設定していません）
で、そちらでは、これでうまくいってますか？
Sheets("リスト").Range("No")とテーブル1[[名前]:[振伝順番]]?は同じ場所です。
前回の時からNoはテープル1になってます。今回書き方が分からなくてマクロの記録で書いたそのまま
を採用してます。説明不足ですいません。
＞＞WorkbookモジュールやSheetモジュールは変更がないのかなと思ってました。
そのあたりは、双方のバージョンをあわせるためにも、正確に連絡してくださいね。
変更はないです。
＞＞ケースとしては、このブロックに、行追加した。で、それは一覧表のテーブルの一番下にある。
なので、新振伝では A列ダブルクリック時にも並び替えが必要になりますよ。
なるほど、言われるとそうですね。
＞＞その時は、貸方合計は４行目、貸方２合計は３行目という状況になりますね。
まぁ、そういう状況がありうるということでコードを考えればいいんですけどね。
ここまで想定できてませんでした。
＞＞こういうところがありますよね。この中の テーブル1 は、（おそらくリストシートの）テーブル名なんですが、これは、仮に解除して再設定すると
別の番号が振られます。テーブル名はブックを通して管理されますので、たとえば テーブル5 といったように。 そうすると、このコードは、実行時エラーになってしまいます。
テーブル名でなくて、Noで大丈夫です。
色々提案ありがとうございます。宜しくお願いします。
（くろ） 2015/07/13(月) 12:55
>>変更はないです。
でもDeactivateイベントは消したんですよね？
まぁ、こうやろうかなという構想はほぼできあがりましたので、コード改定着手します。
（β） 2015/07/13(月) 13:25
＞＞でもDeactivateイベントは消したんですよね？
そうですね。
それは前回作ってもらった旧の方で消したので、
今回は変更ないってことだったのですが、伝えないと分からないですよね。
すいません。
宜しくお願いします。
（くろ） 2015/07/13(月) 13:37
一応書いてみました。 だいぶ、前のことを忘れている部分もあって、連番の取り方や貸方項目のセットの方法に間違いがあるかも。 いずれにしても、レスを分けて、次のレスでコードをアップしますが、ここでは、まず、準備してもらいたいことを含めて メモ的に事前連絡。
１．新振伝では、処理コードの中でテーブル解除->再設定はいっさい行わず、シートに存在するテーブルを、そのまま 永久的に（？）使います。 ２．一覧表シートとリストシートのテーブルに固有の名前をつけます。 前者が "一覧リスト"、後者が "名前リスト" ３．テーブルの名前は、デーブル内を選択してデザインタブの一番左、テーブル名という箱がありますので、そこで規定してください。 （一覧リストについては後述も参考に） ４．そちらのスペックを継承し、Ｈ，Ｋ，Ｍ列（Ｍ列は後述）に式をセットしておき、マクロでは、演算をやめました。 ただし、式そのものは、そちらのコードにあるものとはちょっと変えています。（後述） ５．Reform一覧を、軽〜くしました。並び替えと飾り物のＡ列の番号振り直しだけです。（Ａ列については後述） ６．イベント処理も軽くしました。 １）リストシートのDeActivateは廃止。 ２）一覧シートのChangeイベントは列幅自動調整のみ。 ３）WorkbookのBeforeSave では、reform一覧をやめ、最終行の次のB列の選択だけにしました。 ７．旧振伝の１行の認識 そちらの構想では、この固まりごとにＡ列の番号をユニークに採番ということだったと思いますがコメントしたように 様々な入力のケースを考えると現実的ではありません。 で、あらたにＭ列を設けました。（このＭ列生成は後述） ここに 日付、名前、事業所を連結した文字列を計算式でもっておきます。このＭ列の値が同じものが旧振伝の１行に当たります。 ８．テーブルを使うにあたり、一覧シートのテーブル（一覧リスト）のタイトル文字で以下を指定しています。 そちらのタイトルと合わなければ、コードを変更するなり、タイトルを変更するなりしてください。 Ａ列 連番、Ｂ列 日付、Ｋ列 振伝順番、Ｌ列 事業所。（いずれもreform一覧内でのみ参照）
★今回、一回こっきり、および、同じモジュールにある一覧復旧には手を付けていません。 このままで大丈夫ということではなく、（このままでは大丈夫じゃないです）使う必要がないだろうということです。 元々一回こっきりの役割は、計算式設定と書式設定、ならびにテーブル設定、それと並び替え。（一覧シート、振り伝シート） 書式はすでに設定されていますので、もう設定の必要はないですね。並び替えもとりたてて必要ないですね。 計算式とテーブル設定については次項で。
★一回こっきりの簡易版ですが、テーブル再設定 というマクロを準備。 一覧シートに対して、Ｍ列を追加した上で計算式を埋め込み、Ｍ列を非表示にしてから、テーブル名を"一覧リスト"にしています。 これは、計算式のセットのために、一度やっておいてください。 （β） 2015/07/14(火) 15:32
で、コードです。これ以外のコードは消しておいてください。
●ThisWorkbookモジュール
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
With Sheets("一覧表")
'テーブルの下のＢ列セルを選択
Application.Goto .Cells(.ListObjects("一覧リスト").ListRows.Count + 2, "B")
End With
Application.EnableEvents = True
End Sub
●一覧シート シートモジュール
Option Explicit
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
'選択された行のみの振伝作成(個別)
ReForm一覧
st = WorksheetFunction.Match(Target.EntireRow.Range("M1"), Columns("M"), 0)
cnt = WorksheetFunction.CountIf(ListObjects(1).DataBodyRange.Columns("M"), Target.EntireRow.Range("M1"))
make振伝 st, cnt
Worksheets("振伝").Select
Case 2
'選択された日付をもつデータの振伝作成(全て)
ReForm一覧
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
'列幅自動調整
c.EntireColumn.AutoFit
Next
Application.EnableEvents = True
End Sub
●標準モジュール（本番用）
Option Explicit
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldKey As String
Dim newKey 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 String
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Dim n As Long
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
newKey = sh1.Rows(i).Range("M1")
If oldKey <> newKey Then
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
num = num + 1
'貸方項目、ヘッダー項目
dt = sh1.Rows(i).Range("B1").Value
n = WorksheetFunction.CountIf(sh1.ListObjects(1).DataBodyRange.Columns("M"), newKey)
If n > 1 Then
crItem1 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("G1").Resize(n).Value), "")
crItem2 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("I1").Resize(n).Value), "")
CrAmt1 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("H1").Resize(n))
CrAmt2 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("J1").Resize(n))
Else
crItem1 = sh1.Rows(i).Range("G1").Value
crItem2 = sh1.Rows(i).Range("I1").Value
CrAmt1 = sh1.Rows(i).Range("H1").Value
CrAmt2 = sh1.Rows(i).Range("J1").Value
End If
End If
'借方項目のセット
DrRmk = sh1.Rows(i).Range("D1").Value
DrItem = sh1.Rows(i).Range("E1").Value
DrAmt = sh1.Rows(i).Range("F1").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("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
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
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1
pos.Range("N7").Value = crItem2
pos.Range("S7").Value = CrAmt2
oldKey = newKey
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 ReForm一覧()
Dim r As Range
Dim c As Range
Dim x As Long
With Sheets("一覧表")
'並び替え
.ListObjects("一覧リスト").Sort.SortFields.Clear
.ListObjects("一覧リスト").Sort.SortFields.Add Key:=Range("一覧リスト[日付]"), SortOn:=xlSortOnValues, Order:=xlAscending
.ListObjects("一覧リスト").Sort.SortFields.Add Key:=Range("一覧リスト[振伝順番]"), SortOn:=xlSortOnValues, Order:=xlAscending
.ListObjects("一覧リスト").Sort.SortFields.Add Key:=Range("一覧リスト[事業所]"), SortOn:=xlSortOnValues, Order:=xlAscending
With .ListObjects("一覧リスト").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'A列連番振り直し
.Range("A2").Value = 1
Range("一覧リスト[連番]").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
End Sub
●標準モジュール（臨時）
Option Explicit
Sub テーブル再設定()
Dim fm As String
Dim tmp As Variant
Application.EnableEvents = False
fm = "=IF(M2<>M3,SUMIF(一覧表!$M$2:$M$@,M2,一覧表!$F$2:$F$@)-SUMIF(一覧表!$M$2:$M$@,M2,一覧表!$J$2:$J$@),"""")"
With Sheets("一覧表")
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.Cells.Interior.ColorIndex = xlNone
.Cells.Borders.LineStyle = xlNone
With .UsedRange
fm = Replace(fm, "@", .Rows.Count - 1)
.Columns("H").Offset(1).Resize(.Rows.Count - 1).Formula = fm
.Columns("K").Offset(1).Resize(.Rows.Count - 1).Formula = "=IFERROR(VLOOKUP(C2,名前リスト,2,FALSE),"""")"
.Columns("M").Cells(1).Value = "キー"
.Columns("M").Offset(1).Resize(.Rows.Count - 1).Formula = "=TEXT(B2,""yymmdd"")&C2&IF(L2="""","" "",L2)"
'以下は念のため
With .Columns("J").Offset(1).Resize(.Rows.Count - 1)
tmp = .Value
.ClearContents
.Value = tmp
End With
End With
With .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes)
.Name = "一覧リスト"
.TableStyle = "TableStyleLight15"
End With
'キー列を非表示
.Columns("M").Hidden = True
End With
Application.EnableEvents = True
End Sub
（β） 2015/07/14(火) 15:36
丸投げ状態ですいません。ありがとうございます。
動きがかなり軽いです。
1.Ａ列 連番、Ｂ列 日付、Ｋ列 振伝順番、Ｌ列 事業所へタイトル変更
2.テーブル再設定を実行
3.名前名義 No→名前リストに変更
4.A列をダブルクリック
5.make振伝
'借方項目のセット
DrRmk = sh1.Rows(i).Range("D1").Value
DrItem = sh1.Rows(i).Range("E1").Value
を
'借方項目のセット
DrRmk = sh1.Rows(i).Range("E1").Value
DrItem = sh1.Rows(i).Range("D1").Value
に変更
ここまでやりました。
1.A列の連番が壊れた？row()-1の番号になりました。
2.振伝の1枚目の番号と名前が空白です。
宜しくお願いします。
（くろ） 2015/07/14(火) 16:58
１．Ａ列
ROW()-1 という式は新振伝では使っていないんですが、エクセル行番号よ１つ少ない数ということなら それでいいと思いますが？ データ行は最初が２行目ですよね。
２．番号、名前
コードの記述を忘れてました。
'借方項目のセット
このコメントの上に
'ヘッダー項目のセット
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
を追加してください。
（β） 2015/07/14(火) 17:17
ありがとうございます。
＞＞１．Ａ列
私の勘違いです、M列の結果が出るのかと思ってました。
これで問題ないです。
小出しですいません。
1.貸方の金額が2枚目以降も出てきます。1枚目のみの表示にしたいです。
2.B列でダブルクリックした場合、Noが全ての連番になってます。
A列での結果と同じにしたいです。
宜しくお願いします。
（くろ） 2015/07/14(火) 17:46
やはり、しばらく間を置くと、すっかり、いろんなことを忘れてますねぇ。
make振伝いれかえです。（まだまだ、いろいろあるかもしれませんので検証よろしく）
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldKey As String
Dim newKey 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 String
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Dim n As Long
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
newKey = sh1.Rows(i).Range("M1")
If oldKey <> newKey Then
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
num = 1
'貸方項目、ヘッダー項目
dt = sh1.Rows(i).Range("B1").Value
n = WorksheetFunction.CountIf(sh1.ListObjects(1).DataBodyRange.Columns("M"), newKey)
If n > 1 Then
crItem1 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("G1").Resize(n).Value), "")
crItem2 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("I1").Resize(n).Value), "")
CrAmt1 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("H1").Resize(n))
CrAmt2 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("J1").Resize(n))
Else
crItem1 = sh1.Rows(i).Range("G1").Value
crItem2 = sh1.Rows(i).Range("I1").Value
CrAmt1 = sh1.Rows(i).Range("H1").Value
CrAmt2 = sh1.Rows(i).Range("J1").Value
End If
End If
'ヘッダー項目のセット
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1
pos.Range("N7").Value = crItem2
pos.Range("S7").Value = CrAmt2
'借方項目のセット
DrRmk = sh1.Rows(i).Range("E1").Value
DrItem = sh1.Rows(i).Range("D1").Value
DrAmt = sh1.Rows(i).Range("F1").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("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
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
oldKey = newKey
Next
End Sub
（β） 2015/07/14(火) 18:31
いえいえ、変なお願いばかりですいません。
やはり貸方の合計金額がすべての振伝に出てきます。
よろしくお願いします。
（くろ） 2015/07/14(火) 19:27
こちらでは、とりあえず８行が１つのデータがあって、それに対して、Ａ列ダブルクリックでも、Ｂ列ダブルクリックでも ２枚目の１行だけのほうには、貸方金額が転記されず、空白になっているんですが？
そちらでは、貸方項目の文字列も該当の振伝すべてに記載されてしまっているんですか？
（β） 2015/07/14(火) 20:39
あっ！！ 今、１組のデータを行コピーで２１行にして実行すると再現しました。 ただ、テーブル上の式の結果も、ちょっと変なところがあります。このあたりが影響しているのか？
調べます。
（β） 2015/07/14(火) 20:44
データが8行・15行・22行までの時は1枚目のみが転記されて、2枚目3枚目は空白なのですが、
それ以上のデータになると記入されます。
9行〜14行・16行〜21行・23行〜28行にも入力データがある場合です。
（くろ） 2015/07/14(火) 21:20
make振伝 と テーブル再設定を リバイス願います。
で、一覧シートのタイトルの縛りが増えました。 Ｍ列 キー、これはテーブル再設定で、すでにそうしています。ただ、今まではコード内では使っていなかったのですが式で使うようになりますので。 Ｆ列 金額、Ｊ列 合計2 。これらも式で使います。
で、タイトルを直したら一度、テーブル再設定を実行してください。
あと、コードアップ量が多かったので、このスレも、いっぱいいっぱいになってきましたね。 また皆さんから指導が入るかもしれませんので、Ｎｏ２ を立ち上げてもらえますか？
Sub make振伝(st As Long, cnt As Long)
Dim pos As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim oldKey As String
Dim newKey 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 String
Dim crItem2 As String
Dim CrAmt2 As Long
Dim DrItem As String
Dim DrRmk As String
Dim DrAmt As Long
Dim dt As Date
Dim n As Long
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
newKey = sh1.Rows(i).Range("M1")
If oldKey <> newKey Then
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
num = 1
'貸方項目、ヘッダー項目
dt = sh1.Rows(i).Range("B1").Value
n = WorksheetFunction.CountIf(sh1.ListObjects(1).DataBodyRange.Columns("M"), newKey)
If n > 1 Then
crItem1 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("G1").Resize(n).Value), "")
crItem2 = Join(WorksheetFunction.Transpose(sh1.Rows(i).Range("I1").Resize(n).Value), "")
CrAmt1 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("H1").Resize(n))
CrAmt2 = WorksheetFunction.SumIf(sh1.Rows(i).Range("M1").Resize(n), newKey, sh1.Rows(i).Range("J1").Resize(n))
Else
crItem1 = sh1.Rows(i).Range("G1").Value
crItem2 = sh1.Rows(i).Range("I1").Value
CrAmt1 = sh1.Rows(i).Range("H1").Value
CrAmt2 = sh1.Rows(i).Range("J1").Value
End If
pos.Range("N6").Value = crItem1
pos.Range("S6").Value = CrAmt1
pos.Range("N7").Value = crItem2
pos.Range("S7").Value = CrAmt2
End If
'ヘッダー項目のセット
pos.Range("M2").Value = num
pos.Range("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
'借方項目のセット
DrRmk = sh1.Rows(i).Range("E1").Value
DrItem = sh1.Rows(i).Range("D1").Value
DrAmt = sh1.Rows(i).Range("F1").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("B4").Value = dt
pos.Range("N13").Value = sh1.Rows(i).Range("C1").Value
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
oldKey = newKey
Next
End Sub
Sub テーブル再設定()
Dim fm As String
Dim tmp As Variant
Application.EnableEvents = False
fm = "=IF(一覧リスト[@キー]<>M3,SUMIF(一覧リスト[キー],一覧リスト[@キー],一覧リスト[金額])-SUMIF(一覧リスト[キー],一覧リスト[@キー],一覧リスト[合計2]),"""")"
With Sheets("一覧表")
On Error Resume Next
.ListObjects(1).Unlist
On Error GoTo 0
.Cells.Interior.ColorIndex = xlNone
.Cells.Borders.LineStyle = xlNone
With .UsedRange
.Columns("K").Offset(1).Resize(.Rows.Count - 1).Formula = "=IFERROR(VLOOKUP(C2,名前リスト,2,FALSE),"""")"
.Columns("M").Cells(1).Value = "キー"
.Columns("M").Offset(1).Resize(.Rows.Count - 1).Formula = "=TEXT(B2,""yymmdd"")&C2&IF(L2="""","" "",L2)"
'以下は念のため
With .Columns("J").Offset(1).Resize(.Rows.Count - 1)
tmp = .Value
.ClearContents
.Value = tmp
End With
End With
With .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes)
.Name = "一覧リスト"
.TableStyle = "TableStyleLight15"
End With
With .UsedRange
.Columns("H").Offset(1).Resize(.Rows.Count - 1).Value = fm
End With
'キー列を非表示
.Columns("M").Hidden = True
End With
Application.EnableEvents = True
End Sub
（β） 2015/07/14(火) 21:27
ありがとうございます。
新しいｺｰﾄﾞに変更したら上手くいきました。
かなりいいものになって、入力もラクになり色々ありがとうございました。
困ったことや質問があれば、No2を立てますのでよろしくお願いします。
（くろ） 2015/07/14(火) 22:57
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.