[[20190311130306]] 『月の文字が含まれるシートで処理をさせたい』(佐藤) ページの最後に飛ぶ

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

 

『月の文字が含まれるシートで処理をさせたい』(佐藤)

月別に分かれたシートを集計するための共通項を設定したいのですが、動きません。
(シートの選択のみ動きます)

Sh.Selectの前に仮で「Range("A1")="あああ"」と入れると1月〜11月までは処理されましたが12月は変化なしだし、発着の整理の式を入れても処理はしてもらえませんでした。

Sub 発着地設定()

    Dim sh As Object
    Dim j As Long

'------シート選択

  Const FIND_STR = "月"

  For Each sh In Sheets
    If sh.Name Like "*" & FIND_STR Then

    sh.Select

    '------発着の整理

    For j = 2 To lastrow
        Cells(j, "A") = Range("E" & j).Value & "→" & Range("G" & j).Value

    Next j

    End If
    Next sh

End Sub

< 使用 Excel:Excel2016、使用 OS:Windows10 >


 前回の踏まえていませんが、これでどうでしょう?
    Sub 発着地設定()
        Dim sh As Worksheet
        Dim j As Long
        '------シート選択
        For Each sh In Sheets
            If sh.Name Like "*月" Then
                With sh
                    For j = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                        .Cells(j, "A").Value = .Cells(j, "E").Value & "→" & .Cells(j, "G").Value
                    Next j
                End With
            End If
        Next sh
    End Sub
(稲葉) 2019/03/11(月) 16:02

変化ありません。。。
(もも) 2019/03/11(月) 16:08

 どちら様でしょう?
(稲葉) 2019/03/11(月) 16:12

更新したら自分の掲示板ではないところで返信になってしまいました。
佐藤さま、稲葉さま 失礼いたしました。
(もも) 2019/03/11(月) 16:14

シートの移動もされなくなりました・・・
シート名は1月〜12月で固定なので、指定した方が早いでしょうか?
その方法でやろうとしましたが、シートが選択されるだけで処理をしないため行き詰っていますが・・・
(佐藤) 2019/03/11(月) 16:46

 そらSelectしないですから、見た目はしてないですよ。
 A列が空欄でしたら
 >For j = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
 この部分の"A"を"E"に変えてみてください。
(稲葉) 2019/03/11(月) 16:48

 >シートが選択されるだけで処理をしないため
 これについてコメントしますと、元のコードのlastrowに何も入っていないので0扱い?だから

 >    For j = 2 To lastrow
 2 to 0だとそのまま処理抜けます。

(稲葉) 2019/03/11(月) 16:53


ありがとうございます!A列をE列に変更しましたら上手く動作してくれました。初歩的でした・・・

集計方法を下のマクロを参考に組もうとしているのですが、自分でも応用してやってみますがやり方がおかしかったらご指摘ください。

'====================集計

'Dictionaryオブジェクトをセット
Set DicT = CreateObject("Scripting.Dictionary")
'範囲の最終セル取得
LR = ws1.Cells(Rows.Count, 2).End(xlUp).Row

    '配列化
    Dim i As Long
      '範囲内でKey取得を繰り返す
       For i = 2 To LR
       'Keyが既に配列にある場合は金額を加算する
        If DicT.Exists(ws1.Cells(i, 2).Value) Then
            DicT.Item(ws1.Cells(i, 2).Value) = _
            DicT.Item(ws1.Cells(i, 2).Value) + ws1.Cells(i, 5).Value
        Else
       'Keyがなければ配列に追加する
            DicT.Add ws1.Cells(i, 2).Value, ws1.Cells(i, 5).Value
        End If
       Next i

    '取得したKeyをセルに返す
    Ke = DicT.keys
    For i = 0 To DicT.Count - 1
    ws1.Cells(2 + i, 8) = Ke(i)
    Next i

    '合計したItemをセルに返す
    It = DicT.Items
    For i = 0 To DicT.Count - 1
    ws1.Cells(2 + i, 11) = It(i)

    '---カンマに変更---
    ws1.Cells(2 + i, 11).Select
    Selection.Style = "Comma [0]"
    Next i
(佐藤) 2019/03/11(月) 17:21

 せめてSubからEnd Subまで提示いただけないですか?
 あとインデントもつけていただけると読みやすいです。
(稲葉) 2019/03/11(月) 17:27

 一応提示された範囲で・・・
 あくまで私個人の見解です。
 気づいた点
 1)変数宣言は必ずする
 2)一度しか使わない変数(例えばLRとか)は、分かりにくくならない範囲で使わない
 3)DictionaryはExists判定しなくても、加算とかには使える。(例外あり。DictionaryのItemに配列やオブジェクトを入れるなど。)
 4)Dictionaryはループしなくても、書き出せる(但し、Transposeを使うので、上限あり大体60,000くらい)
 5)Cellsの行番号は、ループで使用しない限り文字列で指定する。(可読性向上)
 6)Selectはまず使わない。(最後に表示させたいシートを出すくらい)
    Sub a()
        Dim dicT As Object
        Dim ws1 As Worksheet
        Dim i As Long
        Set ws1 = Sheets("Sheet1")
        Set dicT = CreateObject("Scripting.Dictionary") 'Dictionaryオブジェクトをセット
        For i = 2 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
            dicT(ws1.Cells(i, "B").Value) = dicT(ws1.Cells(i, "B").Value) + ws1.Cells(i, "E").Value  'B列のキーにE列の値を加算
        Next i
        ws1.Cells(2, "H").Resize(dicT.Count).Value = Application.Transpose(dicT.keys)                'H列にキー(B列の値)を返す
        With ws1.Cells(2, "K").Resize(dicT.Count)
            .Value = Application.Transpose(dicT.items)                                               'K列にアイテム(金額)を返す
            .Style = "Comma [0]"
        End With
        Set dicT = Nothing
    End Sub
(稲葉) 2019/03/11(月) 17:59

説明不足でした。
貼ったものを参考に月の含まれるシートのA列の項目でT列を集計したかったんです。
その場合

 Set ws1 = Sheets("Sheet1")

の部分をどうやって選択するのかを悩んでいました。

A      ・・・ T
あああ→いいい   1000
いいい→あああ   2000
ううう→いいい   10000
あああ→いいい   2000

このようなシートが1月〜12月まで

集計シート
A        B
あああ→いいい  3000
いいい→あああ  5000

と集計したかったです。なんか複雑にしている感じはしますが・・・

(佐藤) 2019/03/11(月) 18:10


 埒空かないので、テストデータこっちで準備しました。
 1)新しいブックを作ってください。
 2)標準モジュールにmkTestDataをコピーして、実行してください。
 3)標準モジュールに集計をコピーして、実行してください。
 こういうことでいいんですか?
 最初の質問とかけ離れていますが、それも付け足すんですか?
    Sub mkTestData()
        Dim i As Long
        For i = 1 To 12
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .Name = i & "月"
                With .Range("A2:A50")
                    .Formula = "=CHOOSE(RANDBETWEEN(1,3),""あああ"",""いいい"",""ううう"")"
                    .Value = .Value
                End With
                With .Range("T2:T50")
                    .Formula = "=RANDBETWEEN(1,9)*1000"
                    .Value = .Value
                End With
            End With
        Next i
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Name = "集計"
        End With
    End Sub
    Sub 集計()
        Dim i As Long
        Dim ws As Worksheet
        With CreateObject("Scripting.Dictionary")
            For Each ws In Sheets
                If ws.Name Like "*月" Then
                    For i = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
                        .Item(ws.Cells(i, "A").Value) = _
                            .Item(ws.Cells(i, "A").Value) + ws.Cells(i, "T").Value  'A列のキーにT列の値を加算
                    Next i
                End If
            Next ws
            Sheets("集計").Range("A1").Resize(.Count).Value = Application.Transpose(.keys)
            Sheets("集計").Range("B1").Resize(.Count).Value = Application.Transpose(.items)
            Sheets("集計").Range("B:B").NumberFormat = "#,##0"
        End With
    End Sub

(稲葉) 2019/03/11(月) 18:36


1〜12月までは既にデータがあります。列は1500行ほどづつです。
A列の組み合わせは200種類ほどあります。
自分には無理だとあきらめていましたが、可能なら集計シートは

A    B       C    D  E
月   発→着     発地  着地 金額
1月度 あああ→いいい あああ いいい 10000



12月度 いいい→かかか いいい かかか 7000

というふうにA列にシート名+度、B列にデータシートA列、E列にその集計としたいです。
(CとE列は「→」の前と後ろで抽出する予定でした)

(佐藤) 2019/03/12(火) 08:47


 まず
 (稲葉) 2019/03/11(月) 18:36
 これで作った表とコードで動くかどうか教えてもらえませんか?
 話はそのあとです。
 >(佐藤) 2019/03/11(月) 18:10
 の提示に沿って作ったデータなので、これが正しくないとすると最初からやり直しになります。

 また
 表を提示する場合は、Wikiの整形ルール(このコメント欄の下方)に沿って
 >行頭を半角スペースで始めると書き込みの改行位置が反映されます。 
 提示してください。

 あるいは下記コードを使って、データシートと集計シートをこちらに張り付けてください。
    ' BrkStr:列間の文字列 初期値は「|」
        '=====================================================
        ' 投稿用シートレイアウトをクリップボードに取得
        '              作成者(momo)
        '
        ' BrkStr:列間の文字列 初期値は「|」
        ' DataObjectID:DataObjectのLate Binding用(変更不可)
        ' http://www.excel.studio-kazu.jp/kw/20110209184943.html
        '=====================================================
        Const BrkStr       As String = "|"
        Const DataObjectID As String = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
        Dim myRng          As Range
        Dim rngFormula     As Range
        Dim rngBuf         As Range
        Dim tbl()          As Variant
        Dim AryTxt()       As String
        Dim StrBuf         As String
        Dim i              As Long
        Dim j              As Long
        Dim cnt            As Long
        Dim AryWidth()     As Long
        Dim LenBuf         As Long
        cnt = 1
        On Error Resume Next
            Set myRng = Application.InputBox("取得したい範囲を選択してください。", Type:=8, Default:=Selection.Address)
        On Error GoTo 0
        If myRng Is Nothing Then
            '何も選択されなかったら、何もしない。
        Else
            'If MsgBox("数式として表示したい範囲はありますか?", vbYesNo) = vbYes Then
                Do
                    On Error Resume Next
                        Set rngBuf = Application.InputBox("数式として表示したい範囲を選択してください。" & cnt & "個目", Type:=8)
                    On Error GoTo 0
                    If Not rngBuf Is Nothing Then
                        If rngFormula Is Nothing Then
                            Set rngFormula = rngBuf
                        Else
                            Set rngFormula = Application.Union(rngFormula, rngBuf)
                        End If
                        cnt = cnt + 1
                    Else
                        Exit Do
                    End If
                    Set rngBuf = Nothing
                Loop 'While MsgBox("さらに数式として表示したい範囲がありますか?", vbYesNo) = vbYes
            'End If
            ReDim tbl(1 To myRng.Rows.Count, 1 To myRng.Columns.Count)
            ReDim AryWidth(1 To UBound(tbl, 2))
            For i = 1 To myRng.Rows.Count
                For j = 1 To myRng.Columns.Count
                    tbl(i, j) = myRng.Cells(i, j).Text
                    If Not rngFormula Is Nothing Then
                        If Not Application.Intersect(myRng.Cells(i, j), rngFormula) Is Nothing Then
                            tbl(i, j) = myRng.Cells(i, j).Formula
                        End If
                    End If
                    LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
                    If AryWidth(j) < LenBuf Then
                        AryWidth(j) = LenBuf
                    End If
                Next j
            Next i
            ReDim AryTxt(UBound(tbl, 1))
            AryTxt(0) = String(Len(myRng.Rows(myRng.Rows.Count).Row) + 3, " ")
            For i = 1 To UBound(tbl, 2)
                StrBuf = "[" & Split(myRng.Columns(i).EntireColumn.Address(False, False), ":")(0) & "]"
                If AryWidth(i) > Len(StrBuf) Then
                    AryTxt(0) = AryTxt(0) & BrkStr & StrBuf & String(AryWidth(i) - Len(StrBuf), " ")
                Else
                    AryTxt(0) = AryTxt(0) & BrkStr & StrBuf
                    AryWidth(i) = Len(StrBuf)
                End If
            Next i
            For i = 1 To UBound(tbl, 1)
                AryTxt(i) = " [" & myRng.Rows(i).Row & "]" & _
                String(Len(myRng.Rows(myRng.Rows.Count).Row) - Len(myRng.Rows(i).Row), " ")
                For j = 1 To UBound(tbl, 2)
                    LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
                    If IsNumeric(tbl(i, j)) Then
                        AryTxt(i) = AryTxt(i) & BrkStr & String(AryWidth(j) - LenBuf, " ") & tbl(i, j)
                    Else
                        AryTxt(i) = AryTxt(i) & BrkStr & tbl(i, j) & String(AryWidth(j) - LenBuf, " ")
                    End If
                Next j
            Next i
            With GetObject("new:" & DataObjectID)
                .SetText Join(AryTxt, vbCrLf)
                .PutInClipboard
            End With
            MsgBox "クリップボードにコピーしました。"
        End If
    End Sub

(稲葉) 2019/03/12(火) 08:57


勘違いしていましたすみません。

(稲葉) 2019/03/11(月) 18:36

こちらのコードで集計出来ました。
ううう 963000
いいい 979000
あああ 1047000
で集計されました。
お手数をおかけしてしまい申し訳ございません。

(佐藤) 2019/03/12(火) 10:01


コメント返信:

[ 一覧(最新更新順) ]


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