[[20081216183241]]　『Sheet1を基準に各作業員の配当』（配当）　ページの最後に飛ぶ

『Sheet1を基準に各作業員の配当』（配当）

 はじめましてよろしくお願いいたします。

 Sheet1が原本になります。									
	Ａ	Ｂ	Ｃ	Ｄ	Ｅ	Ｆ	ＡＫ	ＡＬ	ＡＭ
	日付	曜日	あ	い	う	え	作業員Ａ	作業員Ｂ	作業員Ｃ
5	2007/11/1	木	10	11	12	13	○	○	○
6	2007/11/2	金	10	11	12	13	○	○	×
7	2007/11/3	土	10	11	12	13	○	×	×
8	2007/11/4	日	10	11	12	13	×	○	○
9	2007/11/5	月	10	11	12	13	×	×	○
Sheet2に作業員Ａの配当									
	Ａ	Ｂ	Ｃ	Ｄ	Ｅ	Ｆ	ＡＫ		
	日付	曜日	あ	い	う	え	作業員Ａ		
5	2007/11/1	木	3	3	4	4	○		
6	2007/11/2	金	5	5	6	6	○		
7	2007/11/3	土	10	11	12	13	○		
8	2007/11/4	日	0	0	0	0	×		
9	2007/11/5	月	0	0	0	0	×		
Sheet3に作業員Ｂの配当									
	Ａ	Ｂ	Ｃ	Ｄ	Ｅ	Ｆ	ＡＫ		
	日付	曜日	あ	い	う	え	作業員Ｂ		
5	2007/11/1	木	3	3	4	4	○		
6	2007/11/2	金	5	5	6	6	○		
7	2007/11/3	土	0	0	0	0	×		
8	2007/11/4	日	5	5	6	6	○		
9	2007/11/5	月	0	0	0	0	×		
Sheet４に作業員Ｃの配当									
	Ａ	Ｂ	Ｃ	Ｄ	Ｅ	Ｆ	ＡＫ		
	日付	曜日	あ	い	う	え	作業員Ｃ		
5	2007/11/1	木	3	3	4	4	○		
6	2007/11/2	金	0	0	0	0	×		
7	2007/11/3	土	0	0	0	0	×		
8	2007/11/4	日	5	5	6	6	○		
9	2007/11/5	月	10	11	12	13	○

 上記のようにSheet１を原本としてSheet2,Sheet3,Sheet4へ		
 各、作業員へ配当分を集計したいのですが可能でしょうか？		
 割れないであまりが出た場合は切り捨てて（１０だとして３人○ならば１０÷３で各３ ずつ配当）		
 できればマクロ？でなんて		
 ：マクロを実行すると”メッセージボックス”が出てきて		
 開始の日付は？終わりは？と出てきてその当てはまる日数のみを集計（配当）する何て 出来ればと思い書きました。
 (日付は２～３年分入っています）		
 よろしくお願いいたします。

 無理ではないですかね～
 因みにSheet1をSheet2～Sheet4に指定した日付のデータをコピーと言う具合でかな？
 (スガリ）

 ありがとうございます。やはりそうですか
 私は初心者ですがこの学校のやり取りを見ていてエクセルで不可能は
 あまり無いような気がしまして今回質問しました。（配当）

 出来ないことないですよ。
 提示された条件で組んでみました。
 (ROUGE)
'----
Sub Dividend()
Dim tbl, ans(), i As Long, ii As Long, n As Integer, x(3 To 6) As Long, iii As Long, ss
With Sheets("Sheet1")
    tbl = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).Value
End With
ReDim ans(1 To UBound(tbl, 1), 1 To 37, 1 To 3)
For i = 1 To 3
    For ii = 1 To 36
        ans(1, ii, i) = tbl(1, ii)
    Next
    ans(1, 37, i) = tbl(1, 36 + i)
Next
For i = 2 To UBound(tbl, 1)
    n = IIf(tbl(i, 37) = "○", 1, 0) + IIf(tbl(i, 38) = "○", 1, 0) + _
        IIf(tbl(i, 39) = "○", 1, 0)
    For iii = 3 To 6
        x(iii) = tbl(i, iii) \ n
    Next
    For ii = 1 To 3
        ans(i, 1, ii) = tbl(i, 1)
        ans(i, 2, ii) = tbl(i, 2)
        ans(i, 37, ii) = tbl(i, 36 + ii)
        For iii = 3 To 6
            ans(i, iii, ii) = IIf(ans(i, 37, ii) = "○", x(iii), 0)
        Next
    Next
Next
iii = 0
For Each ss In Array("Sheet2", "Sheet3", "Sheet4")
    iii = iii + 1
    ReDim tbl(1 To UBound(ans, 1), 1 To UBound(ans, 2))
    For i = 1 To UBound(tbl, 1)
        For ii = 1 To UBound(tbl, 2)
            tbl(i, ii) = ans(i, ii, iii)
        Next
    Next
    With Sheets(ss)
        .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).ClearContents
        .Range("A4").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
    End With
Next
End Sub

 (ROUGE)さんありがとうございます。
 ビックリで感動しました。
 でも一つだけＡ列の日付の指定をしては無理なのでしょうか？
 （エラーが出て数字の入っていない部分の日付を消したら出来ました）
 説明不足で追加
 ：マクロを実行すると”メッセージボックス”が出てきて		
 開始の日付は？終わりは？と出てきてその当てはまる日数のみを集計の事です。
（配当）

 こんな塩梅でどうでしょうか。
(ROUGE)
'----
Sub Dividend()
Dim tbl, ans(), i As Long, ii As Long, iii As Long, iv As Long, n As Integer, x(3 To 6) As Long, ss
Dim sDate As Date, eDate As Date
sDate = Application.InputBox("開始日を指定してください。", "開始日", _
    Format(WorksheetFunction.Min(Sheets("Sheet1").Range("A:A")), "yyyy/mm/dd"), Type:=1)
eDate = Application.InputBox("終了日を指定してください。", "終了日", _
    Format(WorksheetFunction.Max(Sheets("Sheet1").Range("A:A")), "yyyy/mm/dd"), Type:=1)
If eDate < sDate Then
    MsgBox "指定された日付は正しくありません。", vbExclamation, "エラー"
    Exit Sub
End If
With Sheets("Sheet1")
    tbl = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).Value
End With
ReDim ans(1 To UBound(tbl, 1), 1 To 37, 1 To 3)
For i = 1 To 3
    For ii = 1 To 36
        ans(1, ii, i) = tbl(1, ii)
    Next
    ans(1, 37, i) = tbl(1, 36 + i)
Next
iv = 1
For i = 2 To UBound(tbl, 1)
    If tbl(i, 1) >= sDate And tbl(i, 1) <= eDate Then
        iv = iv + 1
        n = IIf(tbl(i, 37) = "○", 1, 0) + IIf(tbl(i, 38) = "○", 1, 0) + _
            IIf(tbl(i, 39) = "○", 1, 0)
        For iii = 3 To 6
            x(iii) = tbl(i, iii) \ n
        Next
        For ii = 1 To 3
            ans(iv, 1, ii) = tbl(i, 1)
            ans(iv, 2, ii) = tbl(i, 2)
            ans(iv, 37, ii) = tbl(i, 36 + ii)
            For iii = 3 To 6
                ans(iv, iii, ii) = IIf(ans(iv, 37, ii) = "○", x(iii), 0)
            Next
        Next
    End If
Next
iii = 0
For Each ss In Array("Sheet2", "Sheet3", "Sheet4")
    iii = iii + 1
    ReDim tbl(1 To UBound(ans, 1), 1 To UBound(ans, 2))
    For i = 1 To UBound(tbl, 1)
        For ii = 1 To UBound(tbl, 2)
            tbl(i, ii) = ans(i, ii, iii)
        Next
    Next
    With Sheets(ss)
        .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).ClearContents
        .Range("A4").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
    End With
Next
End Sub

 (ROUGE)ありがとうございます。
 しかし、Ａ～ＦまではコピーででるのですがＧ～ＡＪまでが
 全部コピーされなくて？最初のと比べてみたのですが分からなくて
 何度も申し訳ございません（配当）

 G:AJもなんかあるんですね。。。（当然かｗｗｗ）
 (ROUGE)
'----
Sub Dividend()
Dim tbl, ans(), i As Long, ii As Long, iii As Long, iv As Long, n As Integer, x(3 To 6) As Long, ss
Dim sDate As Date, eDate As Date
sDate = Application.InputBox("開始日を指定してください。", "開始日", _
    Format(WorksheetFunction.Min(Sheets("Sheet1").Range("A:A")), "yyyy/mm/dd"), Type:=1)
eDate = Application.InputBox("終了日を指定してください。", "終了日", _
    Format(WorksheetFunction.Max(Sheets("Sheet1").Range("A:A")), "yyyy/mm/dd"), Type:=1)
If eDate < sDate Then
    MsgBox "指定された日付は正しくありません。", vbExclamation, "エラー"
    Exit Sub
End If
With Sheets("Sheet1")
    tbl = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).Value
End With
ReDim ans(1 To UBound(tbl, 1), 1 To 37, 1 To 3)
For i = 1 To 3
    For ii = 1 To 36
        ans(1, ii, i) = tbl(1, ii)
    Next
    ans(1, 37, i) = tbl(1, 36 + i)
Next
iv = 1
For i = 2 To UBound(tbl, 1)
    If tbl(i, 1) >= sDate And tbl(i, 1) <= eDate Then
        iv = iv + 1
        n = IIf(tbl(i, 37) = "○", 1, 0) + IIf(tbl(i, 38) = "○", 1, 0) + _
            IIf(tbl(i, 39) = "○", 1, 0)
        For iii = 3 To 6
            x(iii) = tbl(i, iii) \ n
        Next
        For ii = 1 To 3
            ans(iv, 1, ii) = tbl(i, 1)
            ans(iv, 2, ii) = tbl(i, 2)
            ans(iv, 37, ii) = tbl(i, 36 + ii)
            For iii = 3 To 6
                ans(iv, iii, ii) = IIf(ans(iv, 37, ii) = "○", x(iii), 0)
            Next
            For iii = 7 To 36
                ans(iv, iii, ii) = tbl(i, iii)
            Next
        Next
    End If
Next
iii = 0
For Each ss In Array("Sheet2", "Sheet3", "Sheet4")
    iii = iii + 1
    ReDim tbl(1 To UBound(ans, 1), 1 To UBound(ans, 2))
    For i = 1 To UBound(tbl, 1)
        For ii = 1 To UBound(tbl, 2)
            tbl(i, ii) = ans(i, ii, iii)
        Next
    Next
    With Sheets(ss)
        .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).ClearContents
        .Range("A4").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
    End With
Next
End Sub

 ありがとうございます。
 ただコピーと言いましたがコピーではなくて最初に書きました
１０だとして３人○ならば１０÷３で各３ ずつ配当）なのですが
 何度も申し訳ございません。
 A～Ｆは上記のようになっていて完璧です。（配当）

 何度も申し訳ございません。
 現在(ROUGE)さんの２回目に教えていただいたマクロでいろいろ
 数字を変更して行っているのですがやはりＡ～Ｆまでしか
 ２回目の式でどこを変更すればSheet2～Sheet4のＡ～ＡＪに
 配当がだせるのでしょうか？教えていただけないでしょうか？（配当）

 おはようございます。
 Fは６番目なのでマクロ内の６の部分を（ＡＪは36)
 と言うことで変えてみましたところ出来ましたが今後なにか問題が
 発生するかと心配で、変更部分は下記の三箇所で行いました。
 Dim tbl, ans(), i As Long, ii As Long, iii As Long, iv As Long, n As Integer, x(3 To 6) As Long, ss　←（6を36)

        For iii = 3 To 6 ←（6を36)

            For iii = 3 To 6 ←（6を36)
 （配当）

 こうなったということですよね？
F:AJにも数値が入っていたんですね。
何かが分からなかったので、そのまま載せるようにしていました（滝汗
(ROUGE)
'----
Sub Dividend()
Dim tbl, ans(), i As Long, ii As Long, iii As Long, iv As Long, n As Integer, x(3 To 36) As Long, ss
Dim sDate As Date, eDate As Date
sDate = Application.InputBox("開始日を指定してください。", "開始日", _
    Format(WorksheetFunction.Min(Sheets("Sheet1").Range("A:A")), "yyyy/mm/dd"), Type:=1)
eDate = Application.InputBox("終了日を指定してください。", "終了日", _
    Format(WorksheetFunction.Max(Sheets("Sheet1").Range("A:A")), "yyyy/mm/dd"), Type:=1)
If eDate < sDate Then
    MsgBox "指定された日付は正しくありません。", vbExclamation, "エラー"
    Exit Sub
End If
With Sheets("Sheet1")
    tbl = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).Value
End With
ReDim ans(1 To UBound(tbl, 1), 1 To 37, 1 To 3)
For i = 1 To 3
    For ii = 1 To 36
        ans(1, ii, i) = tbl(1, ii)
    Next
    ans(1, 37, i) = tbl(1, 36 + i)
Next
iv = 1
For i = 2 To UBound(tbl, 1)
    If tbl(i, 1) >= sDate And tbl(i, 1) <= eDate Then
        iv = iv + 1
        n = IIf(tbl(i, 37) = "○", 1, 0) + IIf(tbl(i, 38) = "○", 1, 0) + _
            IIf(tbl(i, 39) = "○", 1, 0)
        For iii = 3 To 36
            x(iii) = tbl(i, iii) \ n
        Next
        For ii = 1 To 3
            ans(iv, 1, ii) = tbl(i, 1)
            ans(iv, 2, ii) = tbl(i, 2)
            ans(iv, 37, ii) = tbl(i, 36 + ii)
            For iii = 3 To 36
                ans(iv, iii, ii) = IIf(ans(iv, 37, ii) = "○", x(iii), 0)
            Next
        Next
    End If
Next
iii = 0
For Each ss In Array("Sheet2", "Sheet3", "Sheet4")
    iii = iii + 1
    ReDim tbl(1 To UBound(ans, 1), 1 To UBound(ans, 2))
    For i = 1 To UBound(tbl, 1)
        For ii = 1 To UBound(tbl, 2)
            tbl(i, ii) = ans(i, ii, iii)
        Next
    Next
    With Sheets(ss)
        .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Resize(, 39).ClearContents
        .Range("A4").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
    End With
Next
End Sub

 ありがとうございます。
 変更したのと上記の(ROUGE)さんのを印刷をかけて
 重ねて透かして見比べてました。
 同じです。何度も何度もありがとうございました。
 又、問題が出たらよろしくお願いいたします。（配当）

 先日は本当にありがとうございました。
 過去の書き込みを見ながら”自動記録”で下記の事を行おうとしたのですが
 Sheet5に計算式が残ってしまい記録でリンクの貼り付けを行っているから
 だと思うのですが＆実行した時に変な動きがあります。
 下記の事を行いたいのですが

 Sheet2のA5:AJ35を→ Sheet5のA6:AJ36内にコピー
 Sheet3のA5:AJ35を→ Sheet5のA45:AJ75内にコピー
 Sheet4のA5:AJ35を→ Sheet5のA84:AJ114内にコピー

 Sub Macro3()
'
' Macro3 Macro
'

    Sheets("Sheet2").Select
    ActiveWindow.SmallScroll Down:=-6
    Range("A5:AJ35").Select
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.SmallScroll Down:=-15
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    ActiveWindow.SmallScroll Down:=-12
    Range("A6").Select
    ActiveSheet.Paste Link:=True
    ActiveWindow.SmallScroll Down:=24
    Sheets("Sheet3").Select
    ActiveWindow.SmallScroll Down:=-39
    Range("A5:AJ35").Select
    ActiveWindow.SmallScroll Down:=-18
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.SmallScroll Down:=15
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    ActiveWindow.SmallScroll Down:=12
    Range("A45").Select
    ActiveSheet.Paste Link:=True
    ActiveWindow.SmallScroll Down:=30
    Sheets("Sheet4").Select
    ActiveWindow.SmallScroll Down:=-33
    Range("A5:AJ35").Select
    ActiveWindow.SmallScroll Down:=-24
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.SmallScroll Down:=9
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    ActiveWindow.SmallScroll Down:=15
    Range("A84").Select
    ActiveSheet.Paste Link:=True
    ActiveWindow.SmallScroll Down:=24
    Range("G119").Select
 End Sub

 このように記録されました。
 よろしくお願いいたします。（配当）

 「変な動き」と思われる動きは
 具体的にどの様な動きでしょう？

 【リンク】貼り付けをしたいのですよね。

 (HANA)

 画面がチラチラと言うか計算しているみたいです。
 リンクと言うのが間違えかもしれません。
 Sheet2.Sheet3.Sheet4の指定範囲ないの数字を上記に書きましたSheetに
 =○○ではなくて値で数字を移行できればなんですが/
 ↑実行すると各Sheetの＝○○で
 (Sheet5の罫線等は消さないで、あくまで数字のみを）
 なんですが説明不足で申し訳ございません。(配当)

 マクロの記録を録るときは
 シート間の作業はシートを切り替えて記録します。
 セルを選択するときも、実際にそのセルを選択します。
 その動きがそのまま記録され
 プログラムはそれらの切換を瞬く間に行って仕舞うため
 画面がちらちらします。

 出来たコードから不要部分を削除して
 Selectしないコードに変更しすれば
 画面のちらつきは押さえられると思います。

 また、数字のみをコピーしたい場合は
 『値貼り付け(V)』で貼り付けてください。

 '------
Sub Macro3()
    Sheets("Sheet2").Range("A5:AJ35").Copy
    Sheets("Sheet5").Range("A6").PasteSpecial Paste _
        :=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Sheet3").Range("A5:AJ35").Copy
    Sheets("Sheet5").Range("A45").PasteSpecial Paste _
        :=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Sheet4").Range("A5:AJ35").Copy
    Sheets("Sheet5").Range("A84").PasteSpecial Paste _
        :=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Application.CutCopyMode = False
    Sheets("Sheet5").Range("G119").Select
End Sub
 '------

 (HANA)

コメント返信：

[ 一覧(最新更新順) ]

[[20081216183241]] 『Sheet1を基準に各作業員の配当』（配当） ページの最後に飛ぶ

[[20081216183241]]　『Sheet1を基準に各作業員の配当』（配当）　ページの最後に飛ぶ