[[20060304145841]]　『自動でコピー行の移動をしたい』（もも）　ページの最後に飛ぶ

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

　

『自動でコピー行の移動をしたい』（もも）

 縦入力で1日に約200回の取引を入力する単表（10項目位、一部関数使用）があります。
 これを別シートに、行列を入れ替えてコピーしデータベースとして、
 集計出来るようにマクロの記録ボタンを単表上に作りました。
 でも、集計のシートの同じ行に上書きになってしまい、データが蓄積できません。
 行を1行自動で下げて、レコードの更新をするにはどうしたらいいでしょうか。
 入力用単表は、集計シートにコピー後はクリアして、
 また入力の繰り返し（上記マクロの記録最後で）をしています。
 ＶＢＡは私には難しくてわかりませんが、いい解決策はないでしょうか。
 どなたかどうぞお教えください。宜しくお願いします。
 　　　　　　　　　　　　　　　　　　　　　WindowsXP　Excel2000を使っています。

---

 こんにちは。

 >入力用単表シートの
 詳しいレイアウト
 >集計シートの
 レイアウトがわからないと、マクロは組めません。
　　　　　　　　(SHIOJII)

---

SHIOJIIさん　ありがとうございます。

やはりマクロじゃないと無理でしょうか。

エクセルをあきらめて、こちらはもっと超初心者ですが、アクセスでトライしてみます。（もも）

---

 ももさんへ
もう見ていないかもしれませんが、
それほど大変なコードにはならなさそうです。
一度いまあるコードを貼り付けてみてはいかがですか？
(ROUGE)

---

お世話になります。
どう質問すればいいのかもよく解らなくて我ながら困ってしまいます。
マクロの記録のコードを貼り付けました。
宜しくお願いいたします。

Sub ()
'

    Sheets("単票").Select
    Range("F4").Select
    Selection.Copy
    Sheets("集計").Select
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Sheets("単票").Select
    Range("C4:C15").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("集計").Select
    Range("B3").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("単票").Select
    Range("C4").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("C6:C10").Select
    Selection.ClearContents
    Range("C12").Select
    Selection.ClearContents
    Range("C14:C15").Select
    Selection.ClearContents
    Sheets("集計").Select
    ActiveCell.Offset(1, -1).Range("A1").Select
    Sheets("単票").Select
    ActiveCell.Offset(-10, 0).Range("A1").Select
End Sub

---

 試してみてください。
 Sub Test()
    Dim LastRow As Long
    Application.ScreenUpdating = False

    LastRow = Application.Max(3, Sheets("集計").Range("A" & Rows.Count).End(xlUp).Row + 1)

    Sheets("集計").Range("A" & LastRow).Value = Sheets("単票").Range("F4").Value
    Sheets("集計").Range("B" & LastRow).Resize(, 12).Value = _
        WorksheetFunction.Transpose(Sheets("単票").Range("C4:C15").Value)

    Sheets("単票").Range("C4,C6:C10,C12,C14:C15").ClearContents

    Sheets("集計").Select
    Range("A" & (LastRow + 1)).Select
    Sheets("単票").Select
    Range("C4").Select

    Application.ScreenUpdating = True

 End Sub
 （やっちん）

---

自己流の家計簿です。

 メモ欄にはひとつのセルに２０００文字書けるから日記帳にも十分使えます
 これは間違えて２度転送しないようにかかれたマクロです。
 参考になりませんか。
 Sub 転送()
 '加算状況
    If Val(Range("E1")) = "0" Then
        MsgBox ("今回は入力されていませんので加算処理は出来ませんでした。")
        End
    End If
    If Val(Range("F1")) = "1" Then
        MsgBox ("一度加算処理したので今回は加算処理は出来ませんでした。")
        End
    End If
 '転送状況
    If Val(Range("E1")) >= "1" And Val(Range("F1")) = "0" Then
        ActiveWindow.WindowState = xlMinimized
    'シート表示
        Sheets("結果").Visible = True
    '複写
        Dim End_Row As Integer
        If Worksheets("結果").Range("A2").Value = "" Then
        End_Row = 2
        Else
        End_Row = Worksheets("結果").Range("A1").End(xlDown).Row + 1
        End If
        Worksheets("結果").Range("A" & End_Row).Value = Now()
        Sheets("入力").Range("B1:B31").Select
        Selection.Copy
        Sheets("結果").Range("A" & End_Row).PasteSpecial Paste:=xlValues, Operation:=xlNone,  SkipBlanks:= _
            False, Transpose:=True
        Application.CutCopyMode = False
     '文字書式訂正
        Sheets("結果").Select
        Columns("A:A").Select
        Selection.NumberFormatLocal = "G/標準"
        R "A1"
    '並び替え
        Sheets("結果").Select
        Cells.Select
        Selection.EntireRow.Hidden = False
        Selection.EntireColumn.Hidden = False
        Range("A3:AH60000").Select
        Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Range("B3") _
        , Order2:=xlAscending, Key3:=Range("C3"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            SortMethod:=xlPinYin
        ActiveWindow.SelectedSheets.Visible = False
    '年月日入力
        S "入力"
        Worksheets("入力").Range("B1").Formula = "=(YEAR(NOW()))"
        Worksheets("入力").Range("B2").Formula = "=(MONTH(NOW()))"
        Worksheets("入力").Range("B3").Formula = "=(DAY(NOW()))"
        ActiveWindow.WindowState = xlMaximized
        R "A1"
        R "B4"
        Range("E1").Select
        Selection.Copy
        Range("F1").Select
        ActiveSheet.Paste
        Range("B4").Select
        Application.CutCopyMode = False
    End If
 '現在状況消去
    R "B4:B31,F1"
    Selection.ClearContents
    R "B4"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "1"
 End Sub
 Sub 入力()
        Application.MoveAfterReturnDirection = xlDown
    R "B4:B31"
        Selection.ClearContents
    R "B4"
        MsgBox ("!! セルＢ４の収入からＢ３１(水色のセル、現在はB4を選択しています)のメモまでで該当個所に入力後、転送ボタンをクリックしてください。!!")
    R "F1"
    Selection.ClearContents
    R "B4"
 End Sub
 Sub 現在状況()
    Sheets("結果").Visible = True
    Sheets("結果").Select
    Range("A3").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("結果").Visible = True
    S "結果"
    R "D2:AC2"
    Selection.Copy
    S "入力"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "1"
    R "B4"
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    S "結果"
    R "AD2"
    Application.CutCopyMode = False
    Selection.Copy
    S "入力"
    R "B30"
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Application.CutCopyMode = False
    R "B4"
    S "結果"
    ActiveWindow.SelectedSheets.Visible = False
 End Sub
 Sub 現在状況消去()
    R "B4:B31"
        Selection.ClearContents
    R "B4"
 End Sub
 Sub メモを見る()
    Sheets("結果").Visible = True
    S "結果"
    R "D3"
    ActiveWindow.FreezePanes = True
    Columns("D:AD").Select
    Selection.EntireColumn.Hidden = True
    R "AE1"
    Selection.End(xlDown).Select
 End Sub
 Sub メモを閉じる()
    Cells.Select
    Selection.EntireColumn.Hidden = False
    Selection.EntireRow.Hidden = False
    ActiveWindow.FreezePanes = False
    R "A3"
    ActiveWindow.SelectedSheets.Visible = False
    R "B4"
    R "B4"
 End Sub
 Sub 保存終了()
    Windows("和の日記.xls").Activate
    ActiveWorkbook.Save
    Application.Run "和の日記.xls!Excel_quit"
 End Sub
 Sub Excel_quit()
    Application.Quit 'Excelを終了します
 End Sub
 Sub 全消去()
    If MsgBox("全部消去する場合はＯＫ、間違ってこのボタンをクリックした場合はキャンセルをクリックしてください。", vbOKCancel) = vbCancel Then
        End
    End If
    R "B4:B31"
    Selection.ClearContents
    R "B4"
    Sheets("結果").Visible = True
    S "結果"
    R "A3:AC186"
    Selection.ClearContents
    Rows("3:65535").Select
    Selection.Delete Shift:=xlUp
    R "A3"
    R "D2"
    ActiveCell.Formula = "=SUM(D3:D65535)"
    R "D2"
    Selection.Copy
    R "E2:AC2"
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("AE3").Select
    R "A3"
    ActiveWindow.SelectedSheets.Visible = False
    R "B4"
 End Sub
 Sub 訂正()
    Sheets("結果").Visible = True
    S "結果"
    R "A3"
    R "D3"
    ActiveWindow.FreezePanes = True
 End Sub
 Sub 訂正完了()
    '繰越
    ActiveWindow.FreezePanes = False
    Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(rowOffset:=0, columnOffset:=31).Activate
    ActiveWindow.SelectedSheets.Visible = False
    R "B4"
 End Sub
 Public Sub R(TXT As String)
    Range(TXT).Select
 End Sub
 Public Sub S(TXT As String)
    Sheets(TXT).Select
 End Sub

 これが入力シートの内容です。
 年	2006			0	1		
 月	3						
 日	5	上のボタンをクリックした後、収入からメモ欄まで入力してください。					
 収　入							
 衣料費							
 医療費							
 冠婚葬祭							平成18年
 住宅関係							March
 情操教育		入力が終われば｢転送｣をクリックしてください。					弥生
 光熱費							
 交通費							
 小遣い							
 車両関係							
 食　費							
 新聞代							
 掛捨保険							
 テレビ		後日になって入力漏れに気づいたときは年月日を訂正して、通常どうりに入力、 転送してください｡日付は自動で現在に戻ります					
 レジャー							
 タバコ		後日になって部分的に訂正する場合は訂正ボタンをクリックしてください。					
 パソコン							
 生活必需品							
 その他							

 預金							
 現在残金							
 ﾒ    ﾓ 							
 縦に入力したものを横に積み重ねて貼り付けています・
 横だと２５６しかないですからね。
 縦では６５０００以上ありますよね。
 毎日書いても３０年間は使えると思います。
 これが結果のシートです
 年	月	日	収入費	衣料費	医療費	冠婚葬祭	住宅関係	情操教育	光熱費	 交通費	小遣い	車両関係	食　費	新聞代	掛捨保険	テレビ	レジャー	タバコ	パソコン	 生活必需品	その他							預金	 現在残高	メ　　　　　　モ
 現在収支状況			477740 		146100 			8460 	2020 	51230 	438 		8811 					183000 	2599 	2186 	44134 								28762 	メモ
(shota)

---

出来ました!!　
やっちんさん、shotaさん、ROUGEさん、SHIOJIIさん、皆さんありがとうございました。
やっちんさんに教えていただいたコードそのまま貼り付けてうまくいきました。　
感激です。本当にありがとうございました。これから少しずつでもＶＢＡ勉強しようと思います。（もも）

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

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