ここから本文です

【Excel2003or2007 VBA】1ヶ月の分の勤怠表の一部を選択並び替えて別シートに書き...

yas********さん

2012/8/1512:48:00

【Excel2003or2007 VBA】1ヶ月の分の勤怠表の一部を選択並び替えて別シートに書き出しする方法
1ヶ月の分の勤怠の表を別シートに並びかえるマクロを作成していただけないでしょうか。

■現在のシート構成

◆任意のシート:7月,8月,9月と複数シートがあります。シート内の表は以下のようになっています。(,区切り)

名前/日付,1,2,
山田,A特殊,A通常
鈴木,D通常s,D通常
田中,E2nd,E3rd
今田,,A通常
加藤,F通常,A通常

◆別シート:オブジェクト名はKintaiとします。シート内は上に同じくカンマ区切りで以下のようになります。

A,B,C,D,E,F
07:15 - 16:15,07:30 - 16:30,08:00 - 17:00,08:30 - 17:30,09:00 - 18:00
,
,
,
,
,
,
,
,
,
,
,
年休

___・___・___・___・___・___・___・___・___・___・____


■マクロ実行前のユーザの作業

任意のシート内でセルの範囲(一例:B2からB6)を選択した後、同シート内にあるマクロのボタンを実行

■ここからマクロの作業(アルゴリズム?)

Sub 勤怠連絡()
Dim myRange As Range

'1)オブジェクト名:KintaiのセルA1からアクティブな領域の文字列を削除。
'ただし、表の見出しである行1、2は削除しない。尚、選択範囲の行が2未満の場合は実行しない。

'2)オブジェクト名:KintaiのセルA14からアクティブな領域の文字列を削除。
'ただし、表の見出しである行14は削除しない。尚、選択範囲の行が1未満の場合は実行しない。

上記1,2は以下のURLでほぼクリア
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1492360729

'3)選択範囲をループ_For Each 選択範囲の変数 In Selection

'条件1-1
'''処理1
'''セルの文字列の最初の値がBの場合、同行A列の文字列をオブジェクト名:KintaiのB列の表の最下行の空欄(※)にコピーペースト
'''セルの文字列の最初の値がDの場合、同行A列の文字列をオブジェクト名: KintaiのD列の表の最下行の空欄にコピーペースト
'''(※:最初に入力するセルはB3、次回BがあればB4となります)
'''処理2
''''''ペースト後に参照元のセルの背景がデフォルト以外の場合、ペースト先の文字色を同色にします。
''''''一例)任意のシートのセル背景がB2セルが紫で文字が黒い場合、ペースト先は、文字色を紫でペーストします。

'条件1-2
'''選択されているのセルが空欄、あるいはアルファベット以外の文字列の場合は、A列の最終行からCTRL ↑のセルの一つ下に同行A列の文字列をコピーペースト


''ループ終了_Next 選択範囲の変数

End Sub

補足ご回答ありがとうございます!

→完全なプロシージャーをご希望~
申し訳ございません、本件は一旦ストップを希望します。
頂いたコードを見るととても複雑な処理を想定されている気がするので...すみません基本ただの並び替えなんですorz

知恵ノートに作成できたところまでをアップしました。
http://note.chiebukuro.yahoo.co.jp/detail/n102678

閲覧数:
1,366
回答数:
1

違反報告

ベストアンサーに選ばれた回答

2012/8/1601:52:50

Sub Test()

Dim mySheet As Worksheet
Dim myRange(1 To 2) As Range
Dim myCell As Range
Dim myClm(1 To 2) As Long
Dim myRow As Long
Dim myMoji(1 To 2) As Variant
Dim myAddress As String

Set mySheet = ThisWorkbook.Worksheets("Kintai")
myClm(1) = mySheet.Range("A3").End(xlToRight).Column
If myClm(1) = mySheet.Columns.Count Then myClm(1) = 1
'mySheet.Range(Cells(3, 1), Cells(13, myClm)).Delete

myRow = mySheet.Cells(Rows.Count, 1).End(xlUp).Row
myClm(2) = mySheet.Range("A15").End(xlToRight).Column
If myRow = 14 Then myRow = 15
'If myRow > 14 Then mySheet.Range(Cells(15, 1), Cells(myRow, myClm(2))).Delete

myAddress = Selection.Address
Set myRange(2) = ActiveSheet.Range(myAddress)
For Each myRange(1) In myRange(2)
myMoji = myRange(1).Value
myMoji = Left(moji, 1)
Select Case myMoji
Case A To Z
If myMoji = "B" Then

Else
End If
Case Else
End Select
Next myRange

End Sub

ここまで組んでみましたが、以下の点が分からないとこれ以上組めません。完全なプロシージャーをご希望の際には、補足をお願いいたします。

・選択されているセルに入力されているデーターのアルファベットは、BとDの2種類だけか。もし違う時には使用している全てのアルファベット

・条件1-2に書かれているA列のシートは、手動で選択したシートと同じか否か。もし、違うときはそのシート名

・オブジェクト名Kintaiは、シート名かそれともブック名か

・最初に入力するセルは、Bと同様DもD3でよいのかどうか

以上お手数をお掛けいたしますが、よろしくお願いいたします。

質問した人からのコメント

2012/8/18 00:08:13

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

なんとか意図するものができました。
ただ作成中にWithステートメントの利用方法で疑問がうかびました。
新たに質問をたちあげたので、よければご教示ください。

http://detail.chiebukuro.yahoo.co.jp/qa/que_finish.php?qid=13925196...

また全く別のアプローチでコードが作成できるようでしたら、お手すきの時で構いません。併せてご回答ください。

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる