• 締切済み

日付の書式設定が変わってしまうことについて

日付の書式設定が変わってしまうことについて エクセル2000でつくったマクロ（下記）をエクセルXPで使用すると、2010/3/25が 25/3/2010とコピーされてしまいます。 セルの書式をアスタリスクなしに設定しなおしても、マクロを実行するとアスタリスクありの書式でコピーされます。 エクセル2000で実行すると、書式が変わることなくコピーできます。 ヘルプを探しましたが、対策を見つけることができませんでした。 ご存知の方ございましたらご教授願います。 OSはXP　HE　SP３、国設定は日本です。 【マクロ】 Private Sub CommandButton1_Click() Dim i As Long Dim Sh1 As Worksheet Dim Sh2 As Worksheet Set Sh1 = ActiveWorkbook.Worksheets("P") Set Sh2 = ActiveWorkbook.Worksheets("D") Application.ScreenUpdating = False Sh1.Range("A35:X36").Value = Sh1.Range("A32:X33").Value　・・・この段階ではSh1.Range("B35")に2010/3/25とコピーされる・・・ Sh2.Unprotect i = Sh2.Range("A25000").End(xlUp).Offset(1).Row Sh2.Cells(i, 1).Resize(2, 8).Value = Sh1.Cells(35, 1).Resize(2, 8).Value・・・この段階でSh2に25/3/2010とコピーされる・・・ Sh2.Select Sh2.Range("A2:H25000").Select Selection.Sort Key1:=Sh2.Range("C2"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin Sh2.Protect Set Sh1 = Nothing Set Sh2 = Nothing Application.ScreenUpdating = True End Sub

みんなの回答

  • hige_082
  • ベストアンサー率50% (379/747)
回答No.2

valueは値のみを参照するプロパティですよ 書式が必要ならcopyを使用するのが一般的です ＞Sh2.Cells(i, 1).Resize(2, 8).Value = Sh1.Cells(35, 1).Resize(2, 8).Value・・・この段階でSh2に25/3/2010とコピーされる・・・ Sh1.Cells(35, 1).Resize(2, 8).copy Sh2.Cells(i, 1) に変更してはと思います

  • chuchuo
  • ベストアンサー率45% (99/217)
回答No.1

一例です A列に日付のデータが混在しているということだとして 最後に日付データだけ好みの様式に変更してみてはいかがでしょう？ IsDate関数で判定して 日付データのみ FormatDateTime関数で表示形式を設定

hayatekomati50
質問者

お礼

ご回答ありがとうございます。 書式ごとコピーさせるように書き換えたところ、書式が変更されなくなりました。 確かなことはわかりませんが、2002はシート間のValue転記に問題があるようですね

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • アクセスへのエクセルファイルの一括取込みについて

    お世話になっております。 エクセルVBAで所定のフォルダのエクセルファイルから一つのシートにまとめるというマクロを作成しております。アクセスVBAでaccdbファイルで同じことをしたいのですが、アクセスは触ったことがなく、ご教示していただけないでしょうか。 以下エクセルでの取り込みマクロです（長いので一部割愛）。 ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub エクセル取り込み() Dim fpath, fname, buzai, bmst, hantei As String Dim buzaiflg As Boolean Dim wb As Workbook Dim sh1, sh2, sh3, sh4, sh5 As Worksheet Dim dlg As FileDialog Dim TCht As Chart Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set sh1 = ThisWorkbook.Worksheets("データまとめ") Set dlg = Application.FileDialog(msoFileDialogFolderPicker) ' キャンセルボタンクリック時にマクロを終了 If dlg.Show = False Then Exit Sub ' フォルダーのフルパスを変数に格納 fpath = dlg.SelectedItems(1) & "\" Application.DisplayAlerts = False i = 5 pcnt = 2 fname = Dir(fpath & "*.xl*", vbNormal) Do Until fname = "" Set wb = Workbooks.Open(fpath & fname, UpdateLinks:=0) Set sh2 = wb.Worksheets(1) i = i + 1 sh1.Range("A" & i).Value = i - 5 sh1.Range("B" & i).Value = fname sh1.Range("C" & i).Value = sh2.Range("A6").Value sh1.Range("D" & i).Value = sh2.Range("D6").Value sh1.Range("E" & i).Value = sh2.Range("F6").Value sh1.Range("F" & i).Value = sh2.Range("K4").Value sh1.Range("G" & i).Value = sh2.Range("K5").Value sh1.Range("H" & i).Value = sh2.Range("A9").Value 割愛 wb.Close SaveChanges:=False fname = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "終了しました。" End Sub

  • テキストボックスの日付の変更時のみマクロ実行する

    Ｗindows7とＥxcel2007でマクロ作成中の、初心者です。 (1)ブックＡにマクロ書き込み、Ｂブックに処理データがあります。 (2)Ｂブックは毎月一回だけ、書式の変更マクロを実行します。 (3)そのため、苦肉の策として Range("E3")が０のときは、実行するが、１のときはマクロ実行しないように しています。 (4)以上の方法では、更新するときは、いちいちRange("E3")の値を手動で０に する必要があります。面倒です。 (5)そこでＡブックのユーザーフォームに日付の入ったテキストボックスを取り付け ここの日付けが変更されたときだけ、マクロを実行するようにしたいのですが。 難しくて出来ません。教えていただきたいです。お願いします。 Sub 書式の変更操作() Application.ScreenUpdating = False Dim n As Long Dim myBtn As Integer Dim myMsg As String, myTitle As String Dim mydate As Date mydate = Worksheets("集計").Range("D2").Value If Range("E3").Value = 0 Then myMsg = "この" & Format(Range("D2").Value, "m月") & "分 表の書式等を更新します。" myTitle = "書式変更の確認" myBtn = MsgBox(myMsg, vbOKOnly + vbExclamation, myTitle) 書式更新のマクロ実行 Range("E3").Formula = "1"　’ここで次回起動時マクロ実行しない MsgBox "書式を更新しました。" Else MsgBox "既に変更済みです。", vbOKOnly + vbExclamation Exit Sub End If Application.ScreenUpdating = True End Sub

  • 'Range'メソッドは失敗しました

    ExcelのVBAの質問になりますが、教えてください。 下記を動かすと最後の行で「'Range'メソッドは失敗しました: '_Worksheet' オブジェクト」と出ます どうしても最後の行をセレクトしたいのですが、どうしたらよいでしょうか。 Option Explicit Public WB1 As Workbook Public WB1SH1 As Worksheet Public CSVWB1 As Workbook Public CSVWB1SH1 As Worksheet Dim MaxRow As Integer Private Sub CommandButton1_Click() Set WB1 = ActiveWorkbook Set WB1SH1 = WB1.Worksheets(1) Dim a As String a = WB1SH1.Range("a1) Workbooks.Open "C:\Users\User\Desktop\" & a & ".CSV" Set CSVWB1 = ActiveWorkbook Set CSVWB1SH1 = CSVWB1.Worksheets(1) MaxRow = CSVWB1SH1.Cells(Rows.Count, 1).End(xlUp).Row WB1SH1.Activate WB1SH1.Range(Cells(1, 1), Cells(MaxRow, 3)).Select CSVWB1SH1.Activate CSVWB1SH1.Range(Cells(1, 1), Cells(MaxRow, 3)).Select　　'←ここでエラーがでる End Sub

  • 行すべての値を張り付けるようにするには

    次の突合用マクロですが、照合番号だけでなく行すべてのデータを張り付けたいのですが、どの部分に変更を加えればよいかわかりません。 （添付画像をご覧ください） ・Sheet3~6にも列B～以降のデータを張り付けたい EntireRow Copy を使おうとしたのですが、どの様に行を指定すればよいかわかりませんでした。 ご教示頂ければ幸いです。 【準備して頂いたマクロ】 Sub TestX() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Sh3 As Worksheet, Sh4 As Worksheet Dim Sh5 As Worksheet, Sh6 As Worksheet Dim Sh1data As Variant, Sh2data As Variant Dim Sh3data As Variant, Sh4data As Variant Dim Sh5data As Variant, Sh6data As Variant Dim Sh1LastRow As Long, Sh2LastRow As Long Dim i As Long, j As Long, Sh5flg As Boolean Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") Set Sh3 = Worksheets("Sheet3") Set Sh4 = Worksheets("Sheet4") Set Sh5 = Worksheets("Sheet5") Set Sh6 = Worksheets("Sheet6") ReDim Sh3data(0) ReDim Sh4data(0) ReDim Sh5data(0) ReDim Sh6data(0) Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row Sh1data = Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Sh1LastRow, "B")).Value Sh2data = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Sh2LastRow, "B")).Value For i = 1 To Sh1LastRow - 2 Sh5flg = False For j = 1 To Sh2LastRow - 2 If Sh1data(i, 1) = Sh2data(j, 1) Then If Sh2data(j, 2) <> "◯" Then Sh1data(i, 2) = "◯" Sh3data(UBound(Sh3data)) = Sh1data(i, 1) ReDim Preserve Sh3data(UBound(Sh3data) + 1) Sh2data(j, 2) = "◯" Else Sh5data(UBound(Sh5data)) = Sh1data(i, 1) ReDim Preserve Sh5data(UBound(Sh5data) + 1) Sh5flg = True End If Exit For End If Next j If Sh1data(i, 2) <> "◯" And Sh5flg = False Then Sh5data(UBound(Sh5data)) = Sh1data(i, 1) ReDim Preserve Sh5data(UBound(Sh5data) + 1) End If Next i For i = 1 To Sh2LastRow - 2 If Sh2data(i, 2) = "◯" Then Sh4data(UBound(Sh4data)) = Sh2data(i, 1) ReDim Preserve Sh4data(UBound(Sh4data) + 1) Else Sh6data(UBound(Sh6data)) = Sh2data(i, 1) ReDim Preserve Sh6data(UBound(Sh6data) + 1) End If Next Sh1.Range("A3").Resize(Sh1LastRow - 2, 2).Value = Sh1data Sh2.Range("A3").Resize(Sh2LastRow - 2, 2).Value = Sh2data Sh3.Range("A3").Resize(UBound(Sh3data), 1).Value = WorksheetFunction.Transpose(Sh3data) Sh4.Range("A3").Resize(UBound(Sh4data), 1).Value = WorksheetFunction.Transpose(Sh4data) Sh5.Range("A3").Resize(UBound(Sh5data), 1).Value = WorksheetFunction.Transpose(Sh5data) Sh6.Range("A3").Resize(UBound(Sh6data), 1).Value = WorksheetFunction.Transpose(Sh6data) Set Sh1 = Nothing Set Sh2 = Nothing Set Sh3 = Nothing Set Sh4 = Nothing Set Sh5 = Nothing Set Sh6 = Nothing End Sub

  • Excel2000マクロ_ブック名に一貫性が無くて既に開いている物の間のコピー等

    何方か、回答をお願いします。 （A.xlsのAAAシート）（B.xlsのBBBシート）この２つ間のセル値をコピーしたい のですが（共にブック名シート名に一貫性は無しで、既に開いています。） マクロ付.xlsに下記のマクロを書いてA.xlsのAAAシートがアクティブの時にマクロを 実行してtwwにAAAシートをセット出来たのですが、Bk1にB.xlsのBBBシートをセット出来ません。 Application.Waitで止めている間にアクティブシートを変えようとしましたが駄目 Application.Dialogs(xlDialogWorkbookUnhide).Showでも駄目でした。 何方か、マクロ実行中のアクティブシート変更方法を教えて下さい。 又、この様なブック名に一貫性が無くて既に開いている物の間のコピー等はどの様に するのか参考になる物が有れば教えて下さい。 Sub コピー() Dim Bk1 As Worksheet Dim tww As Worksheet Set tww = ActiveWorkbook.Sheets(1) 'ここが分かりません Set Bk1 = ActiveWorkbook.Sheets(1) '-------1個目 tww.Range("D10").Value = Bk1.Range("H9").Value Set Bk1 = Nothing: Set tww = Nothing End Sub

  • マクロ修正お願いします。

    以前質問してマクロを作成してもらった者です。 人事データ用に作っていただきました。 Sheet1 　　A　　　B　　　C 1　処遇　コード　名前．．．． 2　退社　　3　　　あ　　 3　異動　　4　　　か　　 4　入社　　20　　　さ　 Sheet2 　　A　　　B　　　　C 1　コード　名前　　データ1．．． 2　　3　　　あ　　　 3　　4　　　か　　　 4　　 Sub testsample() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim r As Range, c As Range Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range("A2", Sh1.Range("A65536").End(xlUp)) Select Case c.Value Case "入社" 　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A2").End(xlDown).Offset(1) 　'B列より、右端255行を、シート2のA列の最後尾の次にコピーする。 Case "異動" 　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole) 　If Not r Is Nothing Then c.Offset(, 1).Resize(, 255).Copy r 　'コードを検索して、その見つかったものを上書き Case "退社" 　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole) 　If Not r Is Nothing Then r.EntireRow.Delete 　'コードを検索して、その見つかったものを削除 End Select Next End Sub このマクロで一箇所どーしたらいいか分からない場所があります。 「異動」があった場合、sheet1には氏名コードと新しく配属される部署やtelなどのみを書き、メールアドや氏名など異動しても変わらないものは書き込みません。変更があった箇所のみ上書きし空白部分はそのままにしたいです。何度もすみませんがお願いします。

  • マクロの質問です。下記の式があるのですが、コピーしたい、セルには、文字

    マクロの質問です。下記の式があるのですが、コピーしたい、セルには、文字や計算式、又は他のセルから参照させてる物もあるので、張り付けたものに、エラーが数多く表示されるのですが、 コピー元の表示されてる文字を　張り付けることは、できるのでしょうか、 よろしくお願いします。 Sub 給与支払一覧() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "給与支払一覧" And Sh.Name Like "Sheet*" Then With Worksheets("給与支払一覧") If Sh.Range("I14").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("O2:X14").Copy .Cells(1) .Resize(6, 10).Value = Sh.Range("O2:X14").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub

  • ＶＢＡ　なんですが

    ＶＢＡ　なんですが すべてのワークシートを順番に選択して 指定した範囲をコピーし『まとめ』と言う別のシートに貼り付けたいのですが どうしたらいいのかわかりません。 それらしいのは考えたのですが Set sh = Worksheets(sh.Name)でエラーになります。 頭がいいかた教えてください。 　　Dim sh3 As Worksheet Dim sh As Worksheet Dim en As Long Set sh3 = Worksheets("まとめ") For Each sh In ActiveWorkbook.Worksheets If sh.Name <> "まとめ" Then en = sh.UsedRange.Rows.Count Set sh = Worksheets(sh.Name) sh.Range(Cells(2, 1), Cells(en, 10)).Copy

  • ExcelVBAマクロでのデータの受け渡し

    Sheet1「元データ」　　　　　　　　　　　　　　 　　　A　　　B　　 　C　　　D　　　　 1　 0001 みかん　 A店　　3/1　 2 0200　 りんご B店　 3 0311 いちご B店　　3/10 4 　　 いちじく C店 5 0360 メロン　　D店 6 かき　　　P店 7 　0312 キウイ　　D店 Sheet2「最新データ」 　　A　　　B　　 　C　　　D 1　 0001 みかん　 A店　　3/1 2 0190 3 0200　 4 0311 いちご B店　　3/10 5 0422　 洋ナシ C店 6 0250 7 0500 すいか　　P店　 8 　0312 キウイ　　　 　　 とあった時に最新データのA列の番号と元データの番号を見て同じ物があったら、最新データに元データの内容をうつし込むというデータがあります。 Dim Sh1 As Worksheet Dim Sh3 As Worksheet Dim myR As Range Dim N_D As Long Dim i As Long Set Sh1 = Worksheets("元データ") Set Sh3 = Worksheets("最新データ") With Sh3 For i = 5 To .Range("A65536").End(xlUp).Row N_D = .Range("E" & i).Value Set myR = Sh1.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _ MatchCase:=False) If Not myR Is Nothing Then .Range("B" & i & ":D" & i).Value = _ myR.Offset(, 2).Resize(, 3).Value End If Next End With Set Sh1 = Nothing Set Sh3 = Nothing ここで、値は普通にコピーされてくるのですが、 フォントに色がついていたら、その色もつけたいのですが、どうすれば良いのか分らず困っています。 方法がありましたら、教えてください。 よろしくお願いします。

  • マクロの式について教えてください！

    マクロの式について教えてください！ 他で使っていたマクロを書き換えて流用してますが、 エラーなどの表示は、出ないのですが、動きません。 考えられる問題を　教えてください。 おねがいします。　下のような式をつかってます。 Sub 給与支払一覧() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "給与支払一覧" And Sh.Name Like "Sheet*" Then With Worksheets("給与支払一覧") If Sh.Range("H5").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("L1:T5").Copy .Cells(1) .Resize(5, 9).Value = Sh.Range("L1:T5").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub おねがいします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する