[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『月の文字が含まれるシートで処理をさせたい』（佐藤）
月別に分かれたシートを集計するための共通項を設定したいのですが、動きません。
(シートの選択のみ動きます)
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:12
そら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
集計方法を下のマクロを参考に組もうとしているのですが、自分でも応用してやってみますがやり方がおかしかったらご指摘ください。
'====================集計
'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
一応提示された範囲で・・・
あくまで私個人の見解です。
気づいた点
１）変数宣言は必ずする
２）一度しか使わない変数（例えばLRとか）は、分かりにくくならない範囲で使わない
３）DictionaryはExists判定しなくても、加算とかには使える。（例外あり。DictionaryのItemに配列やオブジェクトを入れるなど。）
４）Dictionaryはループしなくても、書き出せる（但し、Transposeを使うので、上限あり大体60,000くらい）
５）Cellsの行番号は、ループで使用しない限り文字列で指定する。（可読性向上）
６）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
Set ws1 = Sheets("Sheet1")
の部分をどうやって選択するのかを悩んでいました。
A ・・・ T
あああ→いいい 1000
いいい→あああ 2000
ううう→いいい 10000
あああ→いいい 2000
このようなシートが1月～12月まで
集計シート
A B
あああ→いいい 3000
いいい→あああ 5000
と集計したかったです。なんか複雑にしている感じはしますが・・・
（佐藤） 2019/03/11(月) 18:10
埒空かないので、テストデータこっちで準備しました。
１）新しいブックを作ってください。
２）標準モジュールにmkTestDataをコピーして、実行してください。
３）標準モジュールに集計をコピーして、実行してください。
こういうことでいいんですか？
最初の質問とかけ離れていますが、それも付け足すんですか？
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
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：列間の文字列 初期値は「|」
'=====================================================
' 投稿用シートレイアウトをクリップボードに取得
' 作成者（ｍｏｍｏ）
'
' BrkStr：列間の文字列 初期値は「|」
' DataObjectID：DataObjectのLate Binding用（変更不可）
' https://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.