[[20150624210958]] 『処理速度を早く、軽くしたい。No.2』(くろ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『処理速度を早く、軽くしたい。No.2』(くろ)

前トピ http://www.excel.studio-kazu.jp/kw/20150618141702.html

長くなったので、新しくしました。よろしくお願いします。

【一覧表】

   A  B   C   D   E   F  ・・・ IS   IT   IU    IV   IW  IX  IY   IZ   JA     JB    
 1 NO 日付 名前 借方1 適用1 金額1 ・・・借方84 適用84 金額84 空白 空白 空白 貸方1 合計1 貸方2 合計2

【振伝】

1行目〜14行目までが1ブロック

1(M2)                 伝票No 
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セル(結合)

【振伝シート】            【一覧表シート】
(M2) 伝票No
(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セル)           貸方1(IY)
(S6〜Z6の8セル)           合計1(IZ)
(N7〜R7の5セル)           貸方2(JA)
(S7〜Z7の8セル)            合計2(JB)
(N13〜R13の5セル)          名前(C) 

〜ここまでが1ブロック〜〜〜

※()が1セル(結合)

★A列ダブルクリック
 該当セルの行を振伝へ

★B列ダブルクリック
 該当セルの同日付全データを振伝へ
 ・行毎にNo.1から(同一名前でも)
 ・合計金額はNo.1のみ
 ・データ件数が84以上になる時はNo.は連番。(続きは下の行)
 ・データ件数が84以上になる時、例えばNo.13の合計はNo.1へプラス。(No.13は空白)

< 使用 Excel:Excel2013、使用 OS:Windows8 >


現状

【一覧表】

 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

    'ReForm一覧                                                                                 '''''(1)

    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

    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

    '念のため入力あった行の数式とA列の連番を再セット

    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("一覧表")
        'テーブルの下のB列セルを選択
        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 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

 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
    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

【標準モジュール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
            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

          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

    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"
        .ListObjects(1).ShowAutoFilterDropDown = False
        .Cells.Borders.LineStyle = xlNone
        .Cells.Interior.ColorIndex = xlNone
    End With
 End Sub

ここまでβさんが作ってもらいました。
''''がある箇所は私が追加・変更したところです。

【問題】

★'''''(1)の場所
 ここだと、新規入力→Case 1実行すると、先に並べ替えになって違う行がでる。

★テーブルが壊れる

★行が違う同一人物のNoが連番になってるのを、それぞれ1から。

★B列でダブルクリックした場合、振伝が複数枚でる人の2枚目以降の名前が違う。

  出力したデータの1番目の人の名前になってる。 

★一覧シートのデータが84を超える時、振伝のNo.13の金額はNo.1に全額合計で出したい。

(くろ) 2015/06/24(水) 22:40


 >>やはりテーブルがおかしくなります。 
 >>私が作ったブックを手動でテーブルにしてみましたが、何の問題もありません。 
 >>何が原因何ですかね? 

 手作業で作ったシートだとブックを開くときにエラーはでず、一回こっきりで設定したものは
 エラーになるということですね?

 う〜ん・・こちらでは、そういった現象が出ていないのでわかりませんねぇ。

 もともと、一回こっきりは、すべて手作業で設定できるものを、ちょっと【サービス】でおまけしたものなので
 これを使わず、手作業で作成したものでいかれたらどうでしょう。

 とはいえ、一応アップしたコードですので、そちらで、一覧表の金額欄や日付欄の書式設定を加えたところをなおして掲載しておきます。
 そちらで対応したものだと2行目しかセットされないようになっていますので。

 >>個別の実行時に動くのは都合が悪いのですが、どこに持っていけばいいですか?

 BeforDoubleClick をアップしておきます。
 なお、保存で新規ブックができるわけですが、処理終了したらどんな状態がお望みですか?
 ・マクロブックの振伝シートが表示される?
 ・新規ブック(6月.xlsx 等)が表示される?

 というか、新規ブック作成(B列ダブルクリック)の場合、振伝シートと新規ブックは内容が全く同じですから
 新規ブックのほうは作成したら閉じてしまったほうが、操作上スムーズかなとおものですがいかが?

 >>★B列でダブルクリックした場合、振伝が複数枚でる人の2枚目以降の名前が違う。 
  出力したデータの1番目の人の名前になってる。

 ですね。チョンボでした。直してアップしました。

 >>★行が違う同一人物のNoが連番になってるのを、それぞれ1から。 
 >>★一覧シートのデータが84を超える時、振伝のNo.13の金額はNo.1に合計で出したい。

 前者は対応しました。
 後者、84を超えるということは一覧シートで次の行になっているということですよね?
 なら、前者対応で自動的に(84を超えても越えなくても)1からになります。

 ●以下のBeforeDoubleClick、make振伝、一回こっきりプロシジャいれかえです。

 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
        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

    ActiveWindow.ActivateNext
    Worksheets("振伝").Select

    Application.EnableEvents = True

 End Sub

 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 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"
        .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

(β) 2015/06/25(木) 01:42


βさん

ありがとうございます。

>>もともと、一回こっきりは、すべて手作業で設定できるものを、ちょっと【サービス】でおまけしたものなので

 これを使わず、手作業で作成したものでいかれたらどうでしょう。

  '.ListObjects.Add xlSrcRange, .UsedRange, , xlYes

    '.ListObjects(1).TableStyle = "TableStyleLight15"
    '.ListObjects(1).ShowAutoFilterDropDown = False

 上記マクロを停止して一回こっきり実行→テーブル設定→保存→閉じる→開く エラーなく開く!!!

 うまくいったのかと、ダブルクリックを実行 エラー

 Microsoft Visual Basic Applications

  次の非表示モジュール内でコンパイル エラーが発生しました:Sheet1
  このエラーが発生するのは、一般的に、コードがこのアプリケーションのバージョン、
 プラットフォーム、またはアーキテクチャと互換性のない場合です。

 がでて、ダブルクリックマクロが動きません。なので新しいマクロは確認できてないです。

>>・マクロブックの振伝シートが表示される? →個別

   ・新規ブック(6月.xlsx 等)が表示される? → 全体

  を希望します。個別は入力ミスの確認の為で、入力の度に実行します。
  全体は印刷時に使用するので、新規ブックが表示されたままが都合がいいです。

>>後者、84を超えるということは一覧シートで次の行になっているということですよね?
  
  はいその通りです。

(くろ) 2015/06/25(木) 10:30


 >> 次の非表示モジュール内でコンパイル エラーが発生しました:Sheet1

 こちらでは発生していないので、何かしら特殊な状況がそちらにあるんだと思われます。
 上記のエラーメッセージを、そのまま検索語にして検索すると、いろいろ出てきます。

http://www.moug.net/faq/viewtopic.php?t=71204
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1427803619
https://support.microsoft.com/ja-jp/kb/307410/ja

 ・AcrobatがらみのAddInが悪さ
 ・本当に Sheet1 という非表示シートがあって、それが悪さ。
  VBE画面の左上のプロジェクトエクスプローラにで、その有無が確認できます。
  Sheet1(●●●) となっているものです。
 ・振伝シートにChangeイベントコードなんかが書かれている?
 ・参照設定で参照不可のものがある??

 等々、そちらの環境で何か合致するものはないですかね?

 >>・マクロブックの振伝シートが表示される? →個別 
 >>・新規ブック(6月.xlsx 等)が表示される? → 全体

 アップしたコードはそうしています。

(β) 2015/06/25(木) 11:12


 ほかの方々からのヘルプをいただくため、別途、以下のトピを立ち上げました。

[[20150625120854]] 『(SOS) テーブル設定されたシート上でのエラ』(β)

 皆さんからのアドバイスも大いに期待しましょう。

(β) 2015/06/25(木) 12:15


(β)さん

ありがとうございます。
Sheet1は非表示ではなくて、一覧表シートなので、マクロはあります。

ダブルクリック後に保存するとエラーになるので、やはり私のPCでは対応してない
何かが含まれるのでしょうか?

(くろ) 2015/06/25(木) 12:41


(β)さん

因みに

 >> 次の非表示モジュール内でコンパイル エラーが発生しました:Sheet1は

(β) 2015/06/25(木) 01:42のマクロに変更したらでました。

それまではこのエラーは出てません。

(くろ) 2015/06/25(木) 13:08


 (SOS)トピに、いろいろアドバイスをもらっています。
 ご覧になっているかもしれませんが以下の手順でどうなるか確認願います。

 その前に整理しますと現状は

 A)一回こっきりでテーブル設定したものを開くとエラー。
 B)一回こっきりからテーブル設定部分を取り除いたもので処理後、手作業でテーブル設定すると、開いてもエラーにはならない。
 C)reform一覧の旧バージョン(テーブル解除、範囲の処理、テーブル再設定)で実行すると、A)もB)も一応処理時エラーはでない。
 D)reform一覧の新バージョン(テーブルのまま処理)で実行すると、B)のケースでエラー

 以下、試してみてOKであれNGであれ、その都度、ブックを保存せずに閉じてください。

 1.まず、現在の B)+D)のまま、A列ダブルクリックで1行だけの振伝処理(新規ブック作成なし)
 2.BeforClick の Application.ScreenUpdating = False をなくしてB列ダブルクリック実行。
 3.Application.ScreenUpdating = False を復活させ、End Select の後に Application.ScreenUpdating = True をいれてB列ダブルクリック実行。
 4.Reform一覧を旧バージョンに戻して、B列ダブルクリック実行。BeforeClickは現在のまま。

 これで思わしくなければ、こちらのマクロブックをどこかにアップし、そちらで、それをダウンロードしてもらって試す方法を考えます。

(β) 2015/06/25(木) 21:47


(β)さん

色々考えてもらってすいません、ありがとうございます。
結果はまた明日試してまた回答させてもらいます。

ひとつ確認なのですが

>>以下、試してみてOKであれNGであれ、その都度、ブックを保存せずに閉じてください

このその都度とは1.2.3.4.を実行する度にブックを保存せずに閉じて開くということですか?

(くろ) 2015/06/25(木) 22:08


 >>このその都度とは1.2.3.4.を実行する度にブックを保存せずに閉じて開くということですか?

 はい。そうです。

(β) 2015/06/25(木) 22:34


(β)さん

4.Reform一覧を旧バージョンに戻して、B列ダブルクリック実行。BeforeClickは現在のまま。

すいません。Reform一覧を旧バージョンとは?

●以下のBeforeDoubleClick、make振伝、一回こっきりプロシジャいれかえです。

ですよね?

(くろ) 2015/06/26(金) 10:12


(β)さん

度々すいません。
理由は分からないのですが、【ThisWorkbook】 のReForm一覧をなくして、
1.A列実行→閉じる(保存)→開く エラーなし
2.B列実行→閉じる(保存)→開く エラーあり

なんですがこの違いが原因ですか?
(くろ) 2015/06/26(金) 10:49


 >>Reform一覧を旧バージョンとは?

 はい。β) 2015/06/25(木) 01:42 のコードです。

 >>理由は分からないのですが、【ThisWorkbook】 のReForm一覧をなくして、 
 >>1.A列実行→閉じる(保存)→開く エラーなし 
 >>2.B列実行→閉じる(保存)→開く エラーあり 

 A列実行はreform一覧と保存がありません。
 この時のreform一覧は旧バージョンですか?新バージョンでしか?

(β) 2015/06/26(金) 11:33


(β)さん

(β) 2015/06/25(木) 01:42 には
BeforeDoubleClick、make振伝、一回こっきりしかないですが?

(くろ) 2015/06/24(水) 22:40をベースに
 BeforeDoubleClick、make振伝、一回こっきりは (β) 2015/06/25(木) 01:42
変更したものを使用してます。

reform一覧が原因なんですかね?
リストシートを変更して保存してもエラーになります。

因みに一回こっきりのテーブル設定も復活しても同じ結果でした。

(くろ) 2015/06/26(金) 12:46


 ●reform一覧

 いろいろリバイスがあって、ごっちゃになってました。

 ・新バージョン 前スレの (β) 2015/06/24(水) 09:56 にアップした、全てをテーブルベースコードにしたもの。
 ・旧バージョン 前スレの、それ以前にアップしていたコード。最終は (β) 2015/06/23(火) 18:43 です。

 いずれにしても、そちらの環境でテーブル設定の影響でエラーになる、その、どこに問題があるのかを突き止めるためにも
 (β) 2015/06/25(木) 21:47  でお願いしている4パターンの結果を教えてください。
 それと、エラーについては、できるだけ詳しく連絡お願いしますね。開いたときにエラーなのか、何かをした時にエラーなになるのか。
 その時のエラー番号とエラーメッセージはもちろんですが、もし、エラーメッセージがでた場合(で、ボタンがあれば)は、デバッグボタンを押し」
 どのコードが黄色く光っているかも教えてくださいね。
(β) 2015/06/26(金) 13:19

βさん

>>1.まず、現在の B)+D)のまま、A列ダブルクリックで1行だけの振伝処理(新規ブック作成なし)

   エラーなし

 2.BeforClick の Application.ScreenUpdating = False をなくしてB列ダブルクリック実行。
   
   エラーなし

 3.Application.ScreenUpdating = False を復活させ、End Select の後に Application.ScreenUpdating = True をいれてB列ダブルクリック実行。

   エラーなし

 4.Reform一覧を旧バージョンに戻して、B列ダブルクリック実行。BeforeClickは現在のまま。

    エラーなし

>>リストシートを変更して保存してもエラーになります。

これは当初から出てるエラーと同じで、保存して開きなおすとでます。

削除されたレコード: /xl/tables/table1.xml パーツ内の並べ替え (テーブル)

エラーが出るのはReform一覧実行後保存開く時です。
  

(くろ) 2015/06/26(金) 14:40


 だいぶしぼられてきました。

 もう1つ、いいですか。

 2.でも、3.でもいいのですが、B列ダブルクリックで振伝作成した後、別の日付のB列を選びダブルクリック。
 こうすると、どうなりますかね?

(β) 2015/06/26(金) 14:47


βさん

>>2.B列ダブルクリックで振伝作成した後、別の日付のB列を選びダブルクリック。

 こうすると、どうなりますかね?
  
 エラーなし 
(2回目のダブルクリック後、応答なしになりましたが、その後作成できました。)

>>次の非表示モジュール内でコンパイル エラーが発生しました:Sheet1

  このエラーが発生するのは、一般的に、コードがこのアプリケーションのバージョン、
 プラットフォーム、またはアーキテクチャと互換性のない場合です。

 このエラーに関しては、他のブックを開いてたのが影響してたのか
 あの後からは出てません。
 惑わせて、すいません、。
(くろ) 2015/06/26(金) 15:06


 >>エラーなし 
 >>(2回目のダブルクリック後、応答なしになりましたが、その後作成できました。)

 試行ありがとうございます。

 エラーなしというのは2回とも、エラーメッセージはでなかったということですね。
 でも2回目は、応答なしで固まったのでしょうか?
 それとも、応答なしになったけど待っていたら戻ったということでしょうか?

 その後作成できたというその後とは、具体的にどういうタイミングですか?

(β) 2015/06/26(金) 15:16


(β)さん

>>エラーなしというのは2回とも、エラーメッセージはでなかったということですね。

  はい、そうです。

>>でも2回目は、応答なしで固まったのでしょうか?

 それとも、応答なしになったけど待っていたら戻ったということでしょうか?

   応答なしで一瞬固まった後、作成できました。

(くろ) 2015/06/26(金) 15:38


 了解です。

 そちらの環境でなぜそうなるのかはわかりませんが、おそらく、こういうコードの組み合わせにしたら
 OKになるだろうという構成を考えてアップします。しばしお待ちを。

(β) 2015/06/26(金) 17:32


 reform一覧 は名前は仰々しいのですが要は、並び替えと、それに伴う A列の番号振り直しをしているだけです。
 で、かってのバージョンは、テーブル解除、処理、テーブル再設定、新しいバージョンは、テーブルのまま処理。
 そちらで試してもらった結果では、いずれも、処理している限りは大丈夫のようですので新しいバージョンで進めるとして
 reform一覧を処理しているタイミングは

 1.B列ダブルクリックによる振伝作成時
 2.BeforeSave
 3.リストシートのDeActivate

 このうち、3.は、必ずしも、この段階では必要ではないと思っています。もちろん、名前順が変更になるわけですから
 即座に反映したほうが気持ちがいいかもしれませんが、新規データを追加して、その日付が必ずしも一番大きくない場合もあり
 その場合には(Chaneイベント)並び替えはしていませんので、割り切って、この3.の処理もなくそうと思っています。

 もう1つ。そちらで発生するブックを開くときの障害は、シートにテーブルが設定されていることが起因していると思われます。
 不思議ですが事実ですから。
 なので、保存してあるブックは、テーブル設定がないもの、つまり通常のブックにしようと思っています。
 そうすると、へんなメッセージの原因そのものがなくなりますので。
 このために、

 ・BeforeClose では、最後に、テーブルを解除。
 ・あらたに Workbook_Open でテーブル設定

 このように対応する予定です。
 この方向でコードを書き直し次第アップします。

(β) 2015/06/26(金) 20:04


(β)さん

全て頼りっぱなしですいません。
ありがとうございます。本当に助かります。
よろしくお願いします。
(くろ) 2015/06/26(金) 20:59


 コードはまだ書き出していません。自分で言った構想そのものの中で「ドツボ」に落ち込んでいます。
 テーブルなしで保存するということは BeforeSaveあたりで、そうしようと思ったんですが、そうすると、
 操作者が、エクセル上の操作でいったんブック保存(閉じずに保存のみ)するとテーブルが解除されてしまうわけで
 そうすると、その後、テーブルありきで実行されるコードでエラーになりますねぇ・・・・
 そのとき、必ず、操作者が、解除されたテーブルを手動で再設定してくれればいいわけですが、そういったことは
 非現実的ですねぇ。

 やはり、こちらの環境では問題なく開くことができるブックがなぜ、そちらで開けないのか。
 これを追及しなきゃいけないかもですね。

 ★新規ブックに以下を貼り付け、実行後、適当な名前で保存して閉じてください。
  で、開きなおしてください。エラーになりますか?なりませんか?
  もし、エラーにならないとすれば、このTestでできあがるシートト、そちらのシートで、(セルの値は別にして)
  どこが違っていますかねぇ。

 Sub Test()
    Dim j As Long

    With Sheets("Sheet1")
        On Error Resume Next
        .ListObjects(1).Unlist
        On Error GoTo 0
        .Cells.Borders.LineStyle = xlNone
        .Cells.Interior.ColorIndex = xlNone
        .Cells.ClearContents
        .Range("A1:JB1").Formula = "=""項目""&COLUMN()"
        .Range("A1:JB1").Value = .Range("A1:JB1").Value
        .Range("A2:JB200").Formula = "=ROW()*COLUMN()"
        .Range("A2:JB200").Value = .Range("A2:JB200").Value
        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 = "#,###"
            End With

        End With

        .ListObjects.Add xlSrcRange, .UsedRange, , xlYes
        .ListObjects(1).TableStyle = "TableStyleLight15"
        .ListObjects(1).ShowAutoFilterDropDown = False

    End With

 End Sub

(β) 2015/06/27(土) 06:40


(β)さん

本当申し訳ないかぎりです。

月曜日にならないと試せないので、また実行後返事させていただきます。
すいません。
(くろ) 2015/06/27(土) 08:14


(β)さん

(β) 2015/06/27(土) 06:40 のマクロは2010だと動かないので確認できてないですし

2010でやった結果なので違うかもしれませんが、

ReForm一覧()の中の

        'With .ListObjects(1).Sort
            '.Header = xlYes
            '.MatchCase = False
            '.Orientation = xlTopToBottom
            '.SortMethod = xlPinYin
            '.Apply
        'End With

 を止めると保存後開き直してもエラーにはなりません。

(くろ) 2015/06/27(土) 11:30


(β)さん

>>ReForm一覧()の中の

        'With .ListObjects(1).Sort
            '.Header = xlYes
            '.MatchCase = False
            '.Orientation = xlTopToBottom
            '.SortMethod = xlPinYin
            '.Apply
        'End With

 ではなくて

'.ListObjects(1).Sort.SortFields.Add Key:=.Range(.ListObjects(1).Name & "[" & strC & "]"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CStr(Join(w, ",")), DataOption:=xlSortNormal

 を止めると保存後開き直してもエラーにはなりません。

(くろ) 2015/06/27(土) 12:10


 情報ありがとうございます。
 今、2010画面を確認しましたが、確かにテーブルのデザインタブのテーブルスタイルオプションには
 ドロップダウン非表示がありませんね。これは2013で追加されたもののようですね。

 当方で、2010で実行すると、やはり、この .ListObjects(1).ShowAutoFilterDropDown = False がエラーになります。
 もし、2010なら、今、検証できるのであれば、この行をコメントアウトして実行してもらえますか?

 ただ、ドロップダウンがない形で 2013で作成されたブックを当方の2010で開いてもエラーにはなりませんし
 振伝作成、保存、再度ブックを開く。こうやってもエラーにはなりませんので不思議なんですよね。

 ところで、(くろ)さんの実行環境には 2010 もありうるということですか?
 であれば、その他にも2013で追加されている要素もあるかもしれず、全体を、2010ベースで見直しをかけるのも
 いいかもしれませんねぇ。ちょっとやってみます。

(β) 2015/06/27(土) 13:10


(β) さん

他の社員は2010を使ってるので、2010ベースにしてもらっていいですか?

>>当方で、2010で実行すると、やはり、この .ListObjects(1).ShowAutoFilterDropDown = False がエラーになります。

 もし、2010なら、今、検証できるのであれば、この行をコメントアウトして実行してもらえますか?

  実行しました。エラーなないです。違いとはどういう部分をみたらいいですか?

ListObjects(1).Sort.SortFields.Add Key:=.Range(.ListObjects(1).Name & "[" & strC & "]"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CStr(Join(w, ",")), DataOption:=xlSortNormal

の件ですが、CustomOrder:=CStr(Join(w, ","))を削除すると保存後開き直してもエラーにはなりません。

(くろ) 2015/06/27(土) 17:40


 まず、今までの報告にあったエラーは、主として xl2010での状況だったようですね。
 ただ、何度か申し上げていますが、こちらのxl2010 では、サポートしていない .ListObjects(1).ShowAutoFilterDropDown = False の実行を除き
 たとえ、xl2013 で作成 した ▼が消されたテーブルを 読みこんでも、エラーにはならないので悩ましいのですが
 いずれにしても、そちらの xl2010 でエラーになるわけですから、そちらの環境でOKにしなければいけないですね。

 基本線としては

 ・テーブル設定では  .ListObjects(1).ShowAutoFilterDropDown = False をなくす。
  (結果、一覧表タイトル行には▼のドロップダウンボタンが表示されますが、これはこれで使い道もあると思います)
 ・その他の処理では、テーブルとして処理する部分を、テーブル解除->並び替え含めて通常範囲の処理->テーブル再設定
  この形でしょうね。

 何度か報告いただいている、並び替えをなくすとエラーが発生しないという部分、通常の並び替えのところではなく
 名前の優先順指定の並び替え部分でしょうけど、これも、そちらのxl2010では、テーブルとしての並び替え指定がなぜかだめ。
 (しつこいようですが、こちらの xl2010 では OKです)

 いずれにしても、この形にしてみましょう。

 今までアップしたコードを使えば、そちらでも、この構成の組み立てはできると思いますが、
 念のため、こちらでフルセット組み立てて 再掲しましょうか?

(β) 2015/06/27(土) 20:31


http://www.moug.net/faq/viewtopic.php?t=72268&sid=d15d00358f84ac375141b64da9e0dfe9
  ↑
 あちらのアドバイスも期待しましょうかねぇ・・・・・。

 ただ、↑の質問文の中には 2013 で作成した ▼なしのシートを2010で開くというところがないのですが
 それは、そちらの環境でも、問題なく開かれ、問題は、テーブル機能の並び替えを使い保存した後開く場合のみということですか?

 ## ただ・・・連絡なく、あちらにもアップ・・・ う〜ん・・・・
 ## あちらも、もともとあったマルチポスト禁止条項が撤廃されていますので、ダメだということはないのですが
 ## その場合でも、こちらにも、なんらかのコメントがほしかったですねぇ。
 ## いずれにしても、マルチポストに関する「学校」のスタンスについては以下を参照願います。
 ## あちらで成果があれば、是非、「学校」へのフィードバックもお願いしますね。

http://www.excel.studio-kazu.jp/wiki/excelboard/index2.html

(β) 2015/06/28(日) 04:59


 あちらは、あちらとして、以下の構成で再掲します。ほとんどが、今までアップしたものと変更有りませんが
 念のためフルセット。(途中で、障害以外にも仕様をあれこれかえていましたので)

 ・2010でサポートされていない.ListObjects(1).ShowAutoFilterDropDown = False をなくす。
 ・並び替え処理含めてreform一覧を テーブル解除->範囲に対する通常処理->テーブル再設定

 こちらでは、2013 で一回こっきりで設定したものを保存し、2010でそれを開いて振伝を何度か作成。
 障害は起きていません。

 さらに、リストシートの変更や一覧シートの変更がない状態ではreform一覧処理をバイパスするのが効率的ですが
 それは盛り込んでいません。

 ●ThisWorkbookモジュール

 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Application.EnableEvents = False
    ReForm一覧
    With Sheets("一覧表")
        'テーブルの下のB列セルを選択
        Application.GoTo .Cells(.ListObjects(1).ListRows.Count + 2, "B")
    End With
    Application.EnableEvents = True
 End Sub

 ●リストシートモジュール

 Private Sub Worksheet_Deactivate()
    Application.EnableEvents = False
    ReForm一覧
    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

    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

    '念のため入力あった行の数式とA列の連番を再セット

    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

 ●標準モジュール 1

 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 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"
        .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
            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("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"
        .Cells.Borders.LineStyle = xlNone
        .Cells.Interior.ColorIndex = xlNone
    End With
 End Sub

(β) 2015/06/28(日) 07:40


(β)さん

少しでも違う人がみてアドバイスをくれたらと思ったのですが、、、
フィードバックは解決できたらするつもりでした。

私が使用するwin8+2013 win7+2010で同じ現象が起きてるのに
回答がないのはまれな現象なんですかね?

開きなおした時、並べ替えが削除(名前)されるのが原因なんだと思うのですが
なぜ削除されるかわかりません。

>>.ListObjects(1).ShowAutoFilterDropDown = False  2010のエラー

>>削除されたレコード: /xl/tables/table1.xml パーツ内の並べ替え (テーブル)  2013 2010のエラー

です。
(くろ) 2015/06/28(日) 10:04


(β)さん

(β) 2015/06/28(日) 07:40のマクロだとA列を実行後保存でもエラーが出るようになりました。

開きなおした時、列の部分が空白になってるんです。並べ変えのキー:値 順序:昇順は入力されてます。

(くろ) 2015/06/28(日) 10:20


(β)さん

違いました。
(β) 2015/06/28(日) 07:40のマクロだとA列を実行後保存でもエラーが出るようになりました。
開きなおした時、列の部分が空白になってるんです。並べ変えのキー:値 順序:昇順は入力されてます。

ではなくて

(β) 2015/06/28(日) 07:40のマクロだとA列を実行後保存でもエラーが出るようになりました。
ReForm一覧()を個別に実行してもホームリボンの並び替えで確認すると、
列の部分が空白になってるんです。並べ変えのキー:値 順序:昇順は入力されてます。

以前のマクロだと、開きなおした時にこの現象でした。

(くろ) 2015/06/28(日) 10:29


 >>(β) 2015/06/28(日) 07:40のマクロだとA列を実行後保存でもエラーが出るようになりました。 

 わかりませんねぇ。
 アップしたフルセットは、もちろん、こちらのコードの最新ですが、これを、A列ダブルクリック、B列ダブルクリック
 そういったことを何度も繰り返し保存し、再度開き、また操作し・・・・
 これを何度もやっていますが、まったくエラーはでません。

 >>ReForm一覧()を個別に実行してもホームリボンの並び替えで確認すると、 列の部分が空白になってるんです。

 まず、だいぶ前にコメントしていますが、個別に実行する場合は、reform一覧直接ではなく、一覧並び替えを実行してください。
 reform一覧直接でも、こちらでは問題なく実行されますが、無駄なChageイベント処理が走ってしまうので。

 それと、「列の部分が空白」、どの列のどの部分が空白になるのですか?
 もちろん、こちらでは、どの列も空白にはなりませんが。
 ますます、怪奇現象ですねぇ。

 >>少しでも違う人がみてアドバイスをくれたらと思ったのですが、、、

 はい。私も期待してますよ。ただ、いきなりだったので。

 >>.ListObjects(1).ShowAutoFilterDropDown = False  2010のエラー 

 これについては、何度も申し上げている通り、xl2010で動かすなら、使えませんので
 2か所あるとおもいますが、コードを削除ですね。(β) 2015/06/28(日) 07:40 のコードでは削除済み。

 もちろん、今、そちらで発生しているのは、この▼の非表示をなくしたもの(つまり▼がついているもの)を
 開き直してエラーということですね。

 >>まれな現象なんですかね?

 う〜ん、世の中の実態がどうなのかはわかりませんが、こちらではOKなので。

 >>開きなおした時、並べ替えが削除(名前)されるのが原因なんだと思うのですが  なぜ削除されるかわかりません。

 これも、何度も申し上げていますが私にもわかりません。
 こちらでは win7+xl2010 でも win8.1+xl2013 でも 開き直してエラーになることはないので。
 (さらに、こちらでは ▼非表示にしたブックを 2010側で開いてもエラーにはなりません)

 もう1つ、見えない状況があります。No に登録されている文字列の中身です。
 こちらでは 田中 とか 佐藤 とか、ありきたりの名前でテストしています。
 もし、この中に、「テーブル機能として処理できない文字」(があるのかどうかわかりませんが)があれば
 具合悪いかもしれませんね。

 そちらのシートの No 欄 の登録を、素直なもの(AAA とか BBB とか CCC とか)にし、一覧表の名前列も
 それらに変更して試してみるのも有効かもしれません。

(β) 2015/06/28(日) 10:43


 あたらしいコード実行前に、もちろん、1回こっきりでテーブル再作成していますよね?

(β) 2015/06/28(日) 10:49


β)さん

>>それと、「列の部分が空白」、どの列のどの部分が空白になるのですか?

前回にも書いてますが、
ホームリボンの並び替えとフィルターで確認すると、

 列の部分が空白になってるんです。並べ変えのキー:値 順序:昇順は入力されてます。 

A列実行の時はこの現象はなかったんですが。

一覧並び替えを実行でも同じ現象です。並び替えが解除されてるってことですか?

>>そちらのシートの No 欄 の登録を、素直なもの(AAA とか BBB とか CCC とか)にし、一覧表の名前列も

 それらに変更して試してみるのも有効かもしれません

 変更しても同じでした。

あたらしいコード実行前に、もちろん、1回こっきりでテーブル再作成していますよね?

 はい、してます。
(くろ) 2015/06/28(日) 11:05

 こちらのテストブックを以下からダウンロードして、そちらの環境でどうなるか試してみてください。

https://free.filesend.to/filedn_infoindex?rp=64280690a83205e868edf7b8e98bff6o

(β) 2015/06/28(日) 11:26


(β)さん

ありがとうございます。
ダウンロードしたものに一覧シート・振伝シートまでは入れ替えても問題なかったのですが
リストシートを入れ替えると同じエラーになります。

色々試してたら、これかもというのが見つかりました。
名前の定義する範囲って何件までってありますか?
Noのデータが66件あるんですが、44件に範囲を減らすとエラーは出ないですが
45件以上になると同様のエラーがでます。

(くろ) 2015/06/28(日) 13:34


ユーザー定義リストの文字数の可能性は?

(マナ) 2015/06/28(日) 14:08


(マナ)さん

回答ありがとうございます。

>>ユーザー定義リストの文字数の可能性は?

 やはり文字制限があるんですか?
 調べているんですが、見つけきれなくて。
(くろ) 2015/06/28(日) 14:24


255文字までのようです。
こちらでも、だいたいその辺りを超えるとエラーが発生しています。

(マナ) 2015/06/28(日) 14:28


 >>調べているんですが、見つけきれなくて。

 見つけきれませんか? 

 報告をもらって、「エクセル 並び替え ユーザー設定リスト 文字数」で検索。
 いくつかでてきます。たとえば、

http://oricyo.hida-ch.com/e592066.html
http://www.editorgoes.net/blog/2014/07/excel_8.html

 そのものズバリの記述はないのですが、1つは文字数制限、1つは項目数制限があるようで
 後者は254が最大のようですね。今回は、66件ですから、これはいいと思いますが、文字数ですね。

http://okwave.jp/qa/q3156969.html

 ここには「推測ベース」での数値紹介があり、これだけ許されているなら66件ならいけるかな?とも思いますが
 PCのメモリーにも依存するようですね。

http://pvttbl.blog23.fc2.com/blog-entry-82.html
http://okwave.jp/qa/q5833247.html

 こんな記述もあります。

 実際のそちらの(, も含めた)合計文字数はどれぐらいになりますか?

 まぁ、環境によって、これが変動するとすれば、安心して使えませんね。
 安全策をとるなら、当初、そちらのコードでやっておられた、優先順位(振伝順番)を
 JC列あたりに復活させて、それを使うか、あるいは、優先順、そのものをなくし、名前順にするか
 いずれかでしょうね。

(β) 2015/06/28(日) 14:41


 こちらでも、リスト文字数を少しずつ増やしながら許容範囲をチェックしました。
 やはり、マナさんおっしゃるように、255文字まではOK(ちなみに項目数は47)
 文字数をそ以上にするとエラーになりました。

 優先順は必須ですか。必須なら、振伝順番復活しか手はないですね。

(β) 2015/06/28(日) 14:54


(マナ) さん

ありがとうございます。
これが原因だったようです。
(くろ) 2015/06/28(日) 15:20


(β) さん

375ありました。まさかこんな制限があるとは思ってもなかったので、盲点でした。
原因が分かってすっきりしました。
本当にお世話になりました。

振伝順番を復活させて対応したいと思います。
長時間おつきあいありがとうございました。

(くろ) 2015/06/28(日) 15:23


 JC列を振伝順番列として加えるなら、アップ済みのreform一覧を以下に。
 それと、あちらのほうにも、結果報告を入れて、閉じておいてください。
 (あちらは閉じないと、ずっと未解決で残りますので)

 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

(β) 2015/06/28(日) 15:32


(β)さん

何から何まで本当にありがとうございました。
助かりました。

あちらにも入力して、解決済みにしておきます。
(くろ) 2015/06/28(日) 15:37


βさん紹介のリンク先を参考に、254項目まで対応?
エラー出てないだけで、できているか不明です。

 w = WorksheetFunction.Transpose(Sheets("リスト").Range("No").Columns(1).Value)
 Application.AddCustomList ListArray:=w

 r.Sort Key1:=Columns(2), Order1:=xlAscending, Header:=xlYes, _
     MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
 r.Sort Key1:=Columns(3), Order1:=xlAscending, Header:=xlYes, _
    MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, _
    OrderCustom:=Application.CustomListCount + 1

 ActiveSheet.Sort.SortFields.Clear
 Application.DeleteCustomList (Application.CustomListCount)

(マナ) 2015/06/28(日) 17:07


(マナ)さん

この方法だとエラーにならないですね!!
この場合Columns(3)の方を先に書かないと、私が求める結果ではなかったですが
これだとユーザー定義リストでの並び替えが可能ですね。
ありがとうございました。
(くろ) 2015/06/28(日) 19:10


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.