- 締切済み
日付のカ増減は特に行っていません
参考日が個々でバラバラのため、セルを下に順繰りに送って基準日と照らし合わせる形をとっています。 下記に簡素ではありますが、プロシージャを貼り付けて置きます。 ご回答いただければ助かります Sub ranking() Dim o As Integer Dim Date1 As Date, Date2 As Date o = 5 Date2 = wsFrom.Cells(16, 3) Date1 = wsFrom.Cells(o, 6)←こちらはきちんとセルごとの参考日が代入されている ↑ここのデータ変数が変わらない Do While Cells(3, o) <> "" If DateDiff("m", Date1, Date2) > 0 Then Cells(7,o).Copy Cells(12,o).paste Else Cells(7,o).Copy Cells(14,o).paste End If o = o + 1 Loop End Sub
- rksksk3669
- お礼率14% (1/7)
- Visual Basic
- 回答数3
- ありがとう数3
- みんなの回答 （3）
- 専門家の回答
みんなの回答
- imogasi
- ベストアンサー率27% (4737/17068)
これは、前に出した質問の補足か？ それならば、その旨と、その質問番号なり書くべきでは？
関連するQ&A
- ExcelVBAで年齢計算
VBAで年齢計算をしたいのですが、「型が一致しない」と怒られます。 A列に誕生日が入っており、B列に年齢が入るようにしたいです。 Sub old() For i = 2 To Cells(2, 1).End(xlDown).Row Dim t As Date Dim b As Date t = Date b = Cells(i, 1) y = DateDiff(b, t, "y") Cells(i, 2) = y Next End Sub どこかおかしいところはありますでしょうか？ 教えてください！
- ベストアンサー
- その他MS Office製品
- やはり図形のクリアで実行時エラー1004
図形を二行三列で一枡とし図形を貼り付けていますが、どうしても実行時エラー 「1004」が出て図形のクリアができません。(尚、四角形は枠線上にあります。) 対処法がありましたらお願いします。 Windows7・SP1 Office2010 Sub 図形の貼付け() Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 9 To 99 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Cells(i + 1, j).Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 5: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 2).Select ActiveSheet.Paste Case 6: ActiveSheet.Shapes("円1").Select Selection.Copy Cells(i, j).Select ActiveSheet.Paste End Select Next Next End Select End Sub Sub 図形のクリア() Dim myRng As Range Set myRng = Range("I10:CW43") Dim n As Integer, sp As Variant For n = ActiveSheet.Shapes.Count To 1 Step -1 Set sp = ActiveSheet.Shapes(n) If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing (ここで実行時エラー1004になります。) Then sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
- DateDiffについて教えてください
初心者です Ｅ列に入力されている日付から今日まで何日経過したかをＫ列に表示したいと思っています。 下記ではエラーになってしまうのですがDateDiffがおかしいのでしょうか？どなたか教えてください。 Sub 経過日カウント() Dim K As Long K = 2 Do While Cells(K, 2) <> "" Cells(K, 11) = DateDiff(Cells(K, 5), Date, "d") K = K + 1 Loop End Sub
- ベストアンサー
- Windows系OS
- 日付が同じなら削除
すみません、誰か教えて頂けませんでしょうか。 A列に日付と時間が記入されているのですが、日付だけを比較して 同じなら削除したいのですが、誰かご教授頂けませんでしょうか。 A列 2013/8/14 8:00 2013/8/14 8:15 2013/8/14 10:00 2013/8/15 8:00 2013/8/16 8:00 2013/8/17 8:00 2013/8/17 20:00 2013/8/18 8:00 2013/8/18 9:00 A列 2013/8/14 8:00 2013/8/15 8:00 2013/8/16 8:00 2013/8/17 8:00 2013/8/18 8:00 Sub 削除 () Dim r As Long Dim y As Long r = Cells(Rows.Count,1).End(xlUp).Row For y = r To 1 Step -1 If Cells(y,1).Value = Cells(y,1).Offset(1,0) Then 'この比較がわかりません。 Cells(y,1).Offset(1,0).Delete(xlUp) End If Next y End Sub すみませんが、宜しくお願いします。
- ベストアンサー
- オフィス系ソフト
- マクロ 別シートへコピー
いつも回答して頂きありがとうございます。 Worksheets("一覧").Paste Range("C3")と記述したら、エラーもかからずうまく貼り付け出来るが、 Worksheets("一覧").Paste Range(Cells(d,3))と記述したらエラーが発生してしまします。どうしたら上手くいくでしょうか？ 下記に作成中のマクロを記載しておきます。 御指導の方よろしくお願いいたします。 Sub シートを繰り返し選択する(2)() Dim d As Integer Dim cVx As Integer d = 3 cVx = Range("IV7").End(xlToLeft).Column Worksheets(Worksheets("一覧").Cells(d, 2).Value).Range("C7:X7").Copy Worksheets("一覧").Paste Range(Cells(d, 3)) End Sub
- ベストアンサー
- オフィス系ソフト
- 【Excel VBA】データ貼り付けの開始位置について
Excel2003を使用しています。 先日、こちらでアドバイスをいただきながら、下記のようなマクロを作りました。内容はあるセルの値と同じ名前のシートへデータをコピーするというものです。 Sheet1に貼り付け元のデータが表形式であり、必要なデータのみ該当のシートへコピーします。マクロ実行後は、別の新しいデータをSheet1へコピペして、またマクロを実行するのですが、その際、データの貼り付け開始位置を前回マクロを実行して貼り付けられたデータから2行空けたいのですが、可能でしょうか？ ________________________________________________________________________________________________________________________________ Sub test3() Dim n As Long Dim i As Long Dim j As Long Worksheets("Sheet1").Activate For n = 4 To Cells(Rows.Count, 2).End(xlUp).Row If Cells(n, 3).Value <> "" Then With Worksheets(CStr(Cells(n, 3).Value)) i = .Cells(Rows.Count, 3).End(xlUp).Row + 1 Cells(n, 2).Copy .Cells(i, 2) Cells(n, 7).Resize(, 2).Copy .Cells(i, 4) Cells(n, 11).Copy .Cells(i, 3) End With End If If Cells(n, 13).Value <> "" Then With Worksheets(CStr(Cells(n, 13).Value)) j = .Cells(Rows.Count, 3).End(xlUp).Row + 1 Cells(n, 12).Copy .Cells(j, 2) Cells(n, 17).Copy .Cells(j, 4) Cells(n, 18).Copy .Cells(j, 6) Cells(n, 11).Copy .Cells(j, 3) End With End If Next n End Sub
- ベストアンサー
- オフィス系ソフト
- vba 対象セルが空白の間動作を繰り返すには？
下記を走らせると、セルが右端まで行ってとまります。 そうなる前に、対象セル範囲が空白になった時点で、動作を止めたいのですが どう記述するのがいいでしょうか？ Dim u As Integer, o As Integer Application.Calculate For u = 2 To 3 For o = 7 To 2000 If Cells(u, o) = "" Then Range("G2").Select Range("G2").End(xlToRight).Select ActiveCell.Resize(6, 5).Select Selection.Cut Range("B2").Select Range("B2").End(xlDown).Select ActiveCell.Offset(1).Select ActiveSheet.Paste End If Next o Next u End Sub
- ベストアンサー
- Visual Basic
- VBA Range・Cellsプロパティについて
下記のコードについて質問致します。 Sub 特定のセルをコピー() Dim rw2 As Long Dim rw1 As Long Dim newdate As Date With Worksheets("steet1") rw2 = .cells(.Rows.Count, "c").End(xlUp).Row newdate = .Range("c" & rw2).value For rw1 = rw2 - 1 To 1 Step -1 If .Range("c" & rw1).value <> newdate Then Exit For Next rw1 .Range(.cells(rw1 + 1, 1), .cells(rw2, 1)).Copy '(1) Worksheets("steet2").Range("v6").PasteSpecial xlValue End With End Sub (1)部分のコードの意味が分かりません。 よろしくお願いします。
- ベストアンサー
- Visual Basic
- マクロ 日付の内容でセルを塗りつぶす
セルに記載された日付が、『TODAY以上なら赤色』・『TODAY以下なら青色』・『それ以外なら塗り潰し無し』にしようと下記のマクロを記述しましたが、思うようになりませんでした。どうしたら治るでしょうか？御指導お願い致します。 Sub セルを色で塗りつぶす() Dim C As Integer C = 5 Do While Cells(5, C).Value <> "" With Cells(6, C) Dim Today As Date Today = Date Select Case .Value Case Is <= Today .Interior.ColorIndex = 8 Case Is >= Today .Interior.ColorIndex = 3 Case Else .Interior.ColorIndex = xlNone End Select End With C = C + 1 Loop End Sub
- ベストアンサー
- オフィス系ソフト
- Excel VBA 一時退避用のセルオブジェクトを作成したい
Excel VBA 一時退避用のセルオブジェクトを作成したい お世話になります。 環境は WindowsXpPro Sp3 Excel2002 Sp3 です。 まず、「やりたいこと」をエクセルではなく通常の変数で書いてみます。 ------------------------------------------- aの値が20を超えていたら元の値に戻したい ------------------------------------------- Dim a As Long Dim temp As Long a = 10 '元の値 temp = a '元の値を保存 a = 30 '変更後の値 If a > 20 Then a = temp Else End If ------------------------------------------- これと同じことをエクセルのCell（単一）に対して行いたいです。 うまくいかないので、Copy,Pasteを使ってみましたが、参照コピーになるようで元に戻せません。 元に戻したいのは、値だけではなく、そのセルに含まれる情報全てです。 なので「セルオブジェクトを退避させて復帰させる」というのを実現させたいです。 うまくいかないので、試しにCopy,Pasteを使って以下のコードを実行してみました。 しかし、参照コピーになっているようで元の値には戻りませんでした。 ------------------------------------------- Cells(10, 5) = 3 Cells(10, 5).Copy '<---- 元の値を保存 Cells(10, 5) = 20 '<---- 値を変更 If Cells(10, 5) > 10 Then ActiveSheet.Paste '<---- 元の値に復帰させたいけれど変更後の「20」になってしまう。 Else End If ------------------------------------------- ペースト先をcells(10,6)等に変えて実行してみると、明らかに参照コピーになっていると思われる動作でした。 処理対象のシート上やブック上へ退避用のセルは作りたくないです。 退避領域のセルを単独で作りたいです。 方法をご存じの方、お手数ですがサンプルコードを提示頂けませんでしょうか。 よろしくお願いします。
- ベストアンサー
- Visual Basic
補足
書き間違いですね。申し訳ありません 正しくはDo While Cells(o、3) <> ""となります。