いつも参考にさせて頂いています。
今回もどなたかのお知恵が借りれる事を祈っております。

Aというファイルに入力されているデータのレイアウトは1行に1案件となっており、
列AからB、C、・・・と報告に必要な項目が並んでいます。
これを各行(=各案件)ごとに専用のファイル(Bファイル)に転写、別名で保存しています。因みにBファイルはAのファイルとはレイアウトが全く異なり、単純に行全体のコピペ~保存という訳にはいかなくて困っています。

■Aファイルのレイアウト
1 A   B   C   D   E   F   G   H   I   L  M
2 No 受付 日付  担当 起票日 起票者 所属  区分  内容 回答日 回答者  
3 1 1111 5/21 MKG 5/31 FSS 1-1 VDA gaga 6/3 GHQ
4 2 1321 5/22 FSB 6/11 CTU 3-1 NCA HAH 6/20 GHQ

データはB列からO列まで入力されていますが、JとKの情報はコピー不要です。
また行数(=案件数)は一定ではなく、何行目までデータが入っているか決まっていません。

■Bファイルへのペースト先(指定したセルにデータが入っている場合は上書き)
AファイルのB列のデータ・・・J5
AファイルのC列のデータ・・・H2
AファイルのD列のデータ・・・D3
AファイルのE列のデータ・・・D7
AファイルのF列のデータ・・・F7
AファイルのG列のデータ・・・I7
AファイルのH列のデータ・・・D8
AファイルのI列のデータ・・・C10
AファイルのL列のデータ・・・D19
AファイルのM列のデータ・・・F19
AファイルのN列のデータ・・・C22

■コピペ後の処理(コピペしたBファイルの別名保存)
BファイルのJ5に貼付けたデータをそのままファイル名としてローカルのデスクトップに保存します。

以上です。
お知恵を貸して下さい!

このQ&Aに関連する最新のQ&A

A 回答 (9件)

masurao200さんも苦労しているようですね。



> 頂いた内容を実行してみると、デスクトップと表示された窓がピコっと出てきます。

デスクトップのパスがちゃんと返ったということですね?

> これを実行するとファイルが生成され最後に実行エラーが出て、Book●●がポツンと存在しています。
> そのままデバッグを押してみると↓の一文が黄色く塗られていました。

わたしも、あなたの掲示したコードをそのままコピペして試してみましたが、ちゃんとデスクトップに複数のBOOK生成されました。
masurao200さんもファイルが生成されデスクトップに保存されているけど、最後にひっかかっちゃうということですね?
こちらではあなたのファイルやパソコンを見ることができないので想像するしかありません。

CreateObject("WScript.Shell").SpecialFolders("Desktop") で取得したパスに続く & "\" & ws(1).Range("E3").Value でファイル名を設定しています。

これらの状況から考えられるのは、エラーになったとき、BファイルのSheet1のE3セルの値が、ファイル名に使えない文字(\/:*?"<>|など)を含んでいるのではないでしょうか?
あるいはひょっとしてすでにデスクトップに存在するファイル名だったとか?
確認してみてください。
あと、AファイルのA列にはデータ数だけNoがふってありますね?
そうでないとデータの数だけファイルが作られませんので。
    • good
    • 0
この回答へのお礼

merlionXX様


いつも本当にありがとうございます。
お蔭様でエラーなく完了することができました。

>あと、AファイルのA列にはデータ数だけNoがふってありますね?
>そうでないとデータの数だけファイルが作られませんので。

実はこの部分を読ませていただき、急いでAファイルを見てみたところ、通しNoが100まで振ってあり、案件が記載してある行は30番までという状況でした。
慌てて31番~100番を消して再度実行してみたところ、エラーなく複製もきちんとコピーされていました。

私の未熟な質問のせいでお手数をかけ、ただただ感謝です。

質問の仕方、マナー、本件以外にも色々と勉強をさせて頂きました。

本当にありがとうございました。

お礼日時:2011/08/12 12:57

> 通しNoが100まで振ってあり、案件が記載してある行は30番までという状況でした。



原因はこれでしたね。
Noとデータ数が常に一致すると限らないなら、Noの列をマクロでは見ないようにしたほうが良かったですね。
そこまで気が回らなかったわたしの落ち度です。反省
(^^;;

B列の「受付」ならデータ数が常に一致するのであれば、cj_moverさまがおっしゃるように
For n = 3 To ws(0).Cells(Rows.Count, "B").End(xlUp).Row
と、B列見るように変えてください。

cj_moverさま、お久しぶりです。
merlionXXはいつまでも未熟で困ったものです。
┐(´∇`)┌
    • good
    • 0

Re


 
ん?
Aファイルで主キーにあたるものはB列にある"受付"なのですから
 回答No.1の記述で
  For n = 2 To ws(0).Cells(Rows.Count, "A").End(xlUp).Row
 の "A" を "B" に正したら案外呆気なく通る
というのが可能性高い気がします。
具体的なデータを見てないので確率的な話ですが試す価値はあるかと。
    • good
    • 0

お邪魔します。



No.1へのお礼に
>A、BどちらもデスクトップにA、Bという名前で保存しています。
とありますから、デスクトップのパス取得に拘らずに
ThisWorkbook.Pathでフォルダを取得する方が後々楽かも知れません。
もっとも、私は、デスクトップにはショートカットしか保存しない主義ですし、
いずれ、どこかのフォルダに格納しなければならない訳ですから、
一時的にであっても、デスクトップにファイル保存するようなプログラムは好みません。
Aファイル、Bファイル、新規に作成するファイル、皆、同一のフォルダに置く
という条件で解釈換えをしてみました。(むしろ一般的な処理です)
同一のフォルダ=デスクトップ、という条件でも当然動きます。

merlionXX さんは結合セルのエキスパートですから、
結合セルが原因で動かないようなものを書くことは滅多にないと思います。
今回、質問者さんが途中から結合セルがエラーの原因と考えて
(そういう疑問を持つことや尋ねることは、寧ろポジティブなことですが)
原質問とは全く異なる(転記するデータの数まで変わってしまう)条件変えをしたのは、
ちょっと勇み足かな、と思います。
回答者としては、継続的なレスポンスが難しくなってしまうのではないでしょうか。
→私が書くのはあくまで、No.5へのお礼が記される前までの情報から類推されるニーズ
に応えるものです。

ところで、
 ファイルAのデータは、
  直に値を入力したものですか?
   それとも他のファイルから取り込んだ(orコピーした)ものですか?
   或いは、数式で他のデータを参照したものでしょうか?
  空白セルや空行はありますか?
なるべく、こういう情報も盛り込むように質問すると、返ってくる内容が充実することが多いです。
(回答者が確認すれば済む、というのも一理、、、)
→B列が空白の場合は転記も新規作成もしないように書きました。
Excelだけでなく表計算ソフト一般にいえる事ですが、
 3-1
のような値は(VBAとは関係なく)結構脆弱です。
文字列として扱うのに、セルの書式設定で文字列を指定することは勿論ですが、
データとして堅牢なものにする為には先頭にプレフィックス「'」を付けた方が確実です。
私は他の表記に換えることが多いですけれど、避けられない場合は
必ず入力(or取り込み)の段階でプレフィックスを付けるようにしています。
→AファイルのG列にプレフィックスを付加するように書いてます。
→そうしたくない場合は◆マークした行を削除してください。
また、Bファイルの転記先のうち、H2,D7,D19については
事前に適切な書式設定(日付)が済んでいるか確認してください。

どちらかというと確認のために書いたコードです。
レスポンスがあれば(日を置いてもよければ)また対応しますが、
本心はmerlionXX さんの手で解決されることを望んでいます。
とりあえず、動作確認をお願いします。

Sub Records2ReportsCrNewBk() ' okg6925811
 Dim vKey As Variant
 Dim wbkRepo As Workbook ' ファイルBブック
 Dim shTbl As Worksheet ' ファイルAシート
 Dim rngTbl As Range ' 元データ(ファイルA)のセル範囲
 Dim rngRepo As Range ' レポート出力先(ファイルB)のセル範囲
 Dim r As Range ' ループ用
 Dim sNrwNmTmpl As String '新規レポートブックのフルネーム雛型
 Dim sNewNm As String ' 新規レポートブックのフルネーム
 Dim nBtmRow As Long ' 元データのデータ最下行
 Dim i As Long, j As Long ' ループ用
 With ThisWorkbook
  Set shTbl = .Sheets("Sheet1")
  sNrwNmTmpl = .Path & "\?.xls"
  nBtmRow = shTbl.Cells(Rows.Count, 2).End(xlUp).Row
  Set rngTbl = shTbl.Range("B:N")
 End With
 On Error GoTo OpenTmpl_
 Set wbkRepo = Workbooks("B.xls")
 On Error GoTo 0
 Set rngRepo = wbkRepo.Sheets("Sheet1").Range("J5,H2,D3,D7,F7,I7,D8,C10,D19,F19,C22")
 For i = 2 To nBtmRow
  With rngTbl.Rows(i)
   vKey = .Cells(1).Value
   If vKey <> "" Then
    j = 0
    For Each r In rngRepo.Areas
     j = j + 1
     Select Case j
      Case 6: .Cells(j).Value = "'" & .Cells(j).Value ' ◆
      Case 9: j = 11
     End Select
     r.Value = .Cells(j).Value
    Next r
    sNewNm = Replace$(sNrwNmTmpl, "?", vKey)
    wbkRepo.SaveAs sNewNm
   End If
  End With
 Next i
' wbkRepo.Close False
Exit_:
 Set wbkRepo = Nothing: Set shTbl = Nothing: Set rngTbl = Nothing: Set rngRepo = Nothing
 Exit Sub
OpenTmpl_:
 Workbooks.Open ThisWorkbook.Path & "\B.xls"
 Resume
End Sub
    • good
    • 0
この回答へのお礼

Cj mover様

お礼が遅くなりましたが、本日目的を果たす事ができました。
教えて頂いたコードでも動作確認させて頂きました。無事、動いております。

質問の仕方、マナーの大切さなどこうしたコミュニティを有効に活用するために大事な事も教えて下さり、本当にありがとうございました。

まだまだ知りたい事が沢山あり、これからも使わせて頂くと思いますので、お時間があればまた教えて下さい。

本当にありがとうございました。

お礼日時:2011/08/12 23:10

ANo4での質問を訂正します。



Sub パス取得()
Dim wb As Workbook
Dim ws(1) As Worksheet
Set wb = Workbooks("B.xls") 'Bファイル指定
Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定
MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
End Sub

では、どう返りますか?
    • good
    • 0
この回答へのお礼

merlionXX様

いつもありがとうございます。面倒かけて申し訳ありません。

頂いた内容を実行してみると、デスクトップと表示された窓がピコっと出てきます。
特にエラーは生じませんでした。

また、Bファイルで指定していた転写先のセルのうち、結合されていたものを全て解除してみました。
セル名が変わったので、最初に頂いた構文のセル名を全て書き換えてみたところ、進展がありました。
実行してみると、各案件別のファイルが生成されデスクトップに保存されています。
しかし、最後に実行時エラーが出てきてしまい、ファイル名の付いていないBook●●(←その時々の数字)が生成されたものの何も転写されておらず保存もされなく開いていました。

セル名を書き直したものは↓です。

Sub test01()
Dim wb As Workbook
Dim ws(1) As Worksheet
Dim myW, myX
Dim i As Long, n As Long
Set wb = Workbooks("B.xls") 'Bファイル指定
Set ws(0) = ThisWorkbook.Sheets("Sheet1") 'Aファイルの転記元シート指定
Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定

myW = Split("B,C,D,E,F,G,I,L,M,N", ",")
myX = Split("E3,E2,C3,C5,E5,E6,B9,C16,E16,B19", ",")

For n = 3 To ws(0).Cells(Rows.Count, "A").End(xlUp).Row
For i = LBound(myW) To UBound(myW)
ws(1).Range(myX(i)).Value = ws(0).Range(myW(i) & n).Value
Next i
ws(1).Copy
ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("E3").Value
ActiveWindow.Close (False)
Next n

End Sub

これを実行するとファイルが生成され最後に実行エラーが出て、Book●●がポツンと存在しています。
そのままデバッグを押してみると↓の一文が黄色く塗られていました。

ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("E3").Value

稚拙な表現ですいません。
何とか助けてください。宜しくお願いいたします。

お礼日時:2011/08/10 20:46

悩ましいですねえ。


マクロはAファイルに書いたのですよね?

Sub デスクトップ取得()
 MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub

は、正しく表示されるのですね?
では

Sub パス取得()
 Set wb = Workbooks("B.xls") 'Bファイル指定
 Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定
 MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
End Sub

ならどうなりますか?
(B.xlsを開いたままで試してください)
    • good
    • 0

merlionXXです。



Windows2000でエクセル2000
WindowsXPでエクセル2003
両方で試しましたがエラーになりません。

Sub デスクトップ取得()
 MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub

で、どう返りますか?
これもエラーならWindowsじゃないのでは?
デスクトップのパスを取得するためにWindows Script Hostを使ったので、Windows環境でなきゃだめなんです。
どうしてもだめなら、
ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
をあなたのデスクトップのパスをそのまま文字列で指定してみてください。

この回答への補足

>転写先が結合しているセルもあります。

大変失礼しました。
転記先のセルの中にはいくつかのセルを結合したものもあり、結合したセルを選択すること自体が何らかの障壁になるかと思って記しました。

関係なければ無視してくださって結構です。

よろしくおねがいします!

補足日時:2011/08/09 17:47
    • good
    • 0
この回答へのお礼

merlionXX様


ご回答ありがとうございます。
当方環境もWinXP&EXCEL 2003です。

頂いたデスクトップ取得については問題なく、ポップアップの画面が掲示されます・
しかし下記ご提供いただいたもので試しますと、同じエラーができます。

ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value

エラーの内容は上記の全文が黄色くセル反転されます。
動作を見ていると、新規ファイルを起こして、そこで終わりです。
新規ファイルには名前は付いていなく、Aファイルからの転写もできていません。
転写先が結合しているセルもあります。

お手数ばかりかけて申し訳ございません。
回答お待ちしております!

お礼日時:2011/08/09 16:46

merlionXXです。



> デバックを選択すると、下記の一文が黄色く反転しています。
> ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop")

あなたのデスクトップのパスを取得する部分ですね。
ここがエラーですか・・・。
あなたのエクセルのバージョンは何でしょう?
    • good
    • 0
この回答へのお礼

ありがとうございます。
本来なら最初の質問で記しておくべきでした。すいません。

エクセルのバージョンは2003です。


よろしくお願いします。

お礼日時:2011/08/09 00:57

一例です。


Aファイルの2行目からデータがあるものとしています。
シート名が不明だったので、A,BファイルともにSheet1としています。
Bファイルは、B.xls としていますが実情に合わせてください。
以下のマクロはAファイルの標準モジュールに記入してください。
実行時にはABファイルともに開いておいてください。

Sub test01()
  Dim wb As Workbook
  Dim ws(1) As Worksheet
  Dim myW, myX
  Dim i As Long, n As Long
  Set wb = Workbooks("B.xls") 'Bファイル指定
  Set ws(0) = ThisWorkbook.Sheets("Sheet1") 'Aファイルの転記元シート指定
  Set ws(1) = wb.Sheets("Sheet1") 'Bファイルの転記先シート指定
  
  myW = Split("B,C,D,E,F,G,H,I,L,M,N", ",")
  myX = Split("J5,H2,D3,D7,F7,I7,D8,C10,D19,F19,C22", ",")
  
  For n = 2 To ws(0).Cells(Rows.Count, "A").End(xlUp).Row
    For i = LBound(myW) To UBound(myW)
      ws(1).Range(myX(i)).Value = ws(0).Range(myW(i) & n).Value
    Next i
    ws(1).Copy
    ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ws(1).Range("J5").Value
    ActiveWindow.Close (False)
  Next n
  
End Sub
    • good
    • 0
この回答へのお礼

さっそくご教示いただきありがとうございます。
実行してみたところ、下記のようなエラーが出ました。

実行時エラー1004

ファイルにアクセスできませんでした。次のいずれかを行ってみてください。
?指定したフォルダがあることを確認します
?ファイルを含むフォルダが読み取り専用になっていないことを確認します
?指定したファイルの名前に次のいずれかの文字も含まれていないことを確認します
<>?[]|:
?ファイル名およびパス名が半角218文字より長くないことを確認します

上から順番に確認しましたが、特に引っかかるものは見当たりません。
A、BどちらもデスクトップにA、Bという名前で保存しています。
シート名もA、BともにSheet1です。

デバックを選択すると、下記の一文が黄色く反転しています。

 ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop")

文中にエラーの原因があるのでしょうか?
教えてください!!!

また出来ましたら、Aファイルの3行目からデータがあるものとして頂けると本当に助かります。

よろしくお願いします。。。

お礼日時:2011/08/08 21:43

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QVBAで、アクティブなBOOKのファイル名を取得し

エクセルのVBAを使用して、選択されている、BOOKのファイル名を取得し、下記のように編集してA1セルに入れたいのですが、可能でしょうか?


BOOKのファイル名が「大阪_たこ焼き_1234.xls」の場合

大阪_と.xlsをは省いて、「たこ焼き_1234」がA1セルに入るようにしたい。

Aベストアンサー

拡張子なんでもござれ!
Sub TheBody()
Const xSeparator = "_"
Const xPeriod = "."
Dim KitCut As Variant
KitCut = Split(ActiveWorkbook.Name, xPeriod)
KitCut = Split(KitCut(0), xSeparator)
Range("A1").Value = KitCut(1) & xSeparator & KitCut(2)
Columns("A").AutoFit
End Sub

Qいつもとても参考にしております。エクセルの時間と速度の単位換算とその計

いつもとても参考にしております。エクセルの時間と速度の単位換算とその計算使い方について教えてください。
エクセル2000で虫の移動速度(2km/h=固定値)と移動時間(分:秒表示)と移動距離(m表示)を一覧表にしたいのですがどうもうまくいきません。

移動速度は固定値として計算するのですがA列セルには移動時間、B列セルには移動距離を計算値として表わしたいと思ってます。
A1セルには「セルの書式設定」で「ユーザー定義」として「[mm]:ss」と設定したらうまく表示されたのですが速度が「時速表示」、移動時間が「分秒表示」、移動距離が「m表示」なので単位が統一の仕方すら分からないので途方にくれてます。

エクセルのド素人の私にどなたか判りやすく教えていただけませんでしょうか?
宜しくお願い致しますお願い致します。

Aベストアンサー

No.1・4です!
またまたお邪魔します。

B列を計算に使いたいわけですよね?
たぶん、No.1の方法の文字列の方でB列を表示していないでしょうか?
(数式の最後に「&"m"」を付けていませんか?)

文字列を加減乗除に使用すると当然エラーになってしまいます。

そこで今回はROUND関数を使わずにセルの書式設定だけで操作してみてはどうでしょう?

B列の数式をNo.1のように
=2000*A2*24
として、表示形式だけ変更します。
B列すべてを範囲指定 → 右クリック → セルの書式設定 → 表示形式 → ユーザー定義 から
0.00"m" と入力してOK
これでセル内は単純に小数点以下二桁の数値になり、見た目は「○.○○m」のようになります。

そして、計算結果を表示したいセルの表示形式も同様の設定を行い、
単純にお示しの計算で大丈夫だと思いますよ。

試してみてください。
参考になれば良いのですが・・・m(__)m

QExcelVBA:自己のBook名を取得したい

WindowsXP-Proです。
Excelヴァージョンは2003です。

ExcelVBAでコーディングしています。
で、自分自身(つまり、このVBAコードを記述しているExcel本体)のBook名を取得したいのですが、何か関数は用意されていますでしょうか?

自分自身のBook名を取得したい理由は、VBAコードを記述しているExcel本体のファイル名(Book名)の名前が変更されても、VBAが正常に機能するように、今現在のBook名を取得したいのです。

複数のExcelファイルを、このVBAで操作しているため、
Workbooks("本体のBook名").Activate
を用いており、仮にファイル名(本体のBook名)の名前が変更されても、VBAが正常に機能できるように、"本体のBook名"部分を固定ではなく、可変で持てるようにしたいからです。

Aベストアンサー

Public Sub Auto_Open()
  MsgBox ActiveWorkbook.Name
  MsgBox ThisWorkbook.Name
End Sub

Private Sub Workbook_Open()
  MsgBox Me.Name
End Sub

いずれも、ブック名が表示されました。

Qエクセルを新規で開いても既存のExcelを開いてもいつも変なマクロがくっ付いています。どうすれば取ることができるでしょうか?

今日気づいたのですが、エクセルを新規で開いても既存のExcelを開いてもいつも変なマクロがくっ付いています。どうすれば取ることができるでしょうか?
VBEを開くとfuncres(FUNCRES.XLA)という身に覚えのないマクロがありました。開放しようとしてもボタンが押せない状態で削除できません。パスワードもかかっており中身を見ることもできません。
ウイルスなんでしょうか?対処方法についてご存知の方、教えてください。よろしくお願いします。

Aベストアンサー

分析ツールです。

FUNCRES.XLAとは
http://www.relief.jp/itnote/archives/001707.php

Q他のワークシート名の取得方法 (VBAを使用せずに)

VBAを用いずに、ワークシート関数のみでワークシート名を取得できないか探しています。

自分のシート名は、以下の出力結果の一部より取得することができました。
=CELL("filename")

しかし、他のシート名を取得する方法が思いもつきません。

VBAを用いずにシート名を取得することはできないのでしょうか?

Aベストアンサー

Excel2000でしたら、
1.[挿入]-[名前]-[定義] から、名前を2つ定義します。
  ・名前:PPP  参照範囲:=GET.WORKBOOK(1)
  ・名前:QQQ  参照範囲:=GET.DOCUMENT(88)
2.A1 に =SUBSTITUTE(INDEX(PPP,ROW()),"["&QQQ&"]","") と入力します。
3.A1 を下方にドラッグコピーすると、シート名が一覧で表示されます。

例えば3枚目のシート名のみを取得する場合は、任意のセルに
=SUBSTITUTE(INDEX(PPP,3),"["&QQQ&"]","") と入力します。

※マクロ関数というものですが、最近のバージョンにこれが付帯されているのかどうか
  わかりませんが。   ^_^;

QVBA データ左側から3文字で分類し新規シート転記

お知恵を貸して下さい。
エクセルに入力された問合せ内容をまとめていく上で困っています。
2列目の会員種別に入力されているデータがくせ者で、左側ら3文字で会員の種類が分かれます。

やりたい仕事は、この会員種別ごとに新規でシートを起こし、3文字mmというタイトルで(mmは上書きで書き換えます)保存までを自動化でしたいのです。
その際、元のデータから特定のセルを選んで転記するのではなく、あくまで会員種別の左から3文字で仕分けます。行は丸ごとコピーする必要があります。

新規シートでシート名までを自動で作成したいのでVBAかと思いまして。

どなたか助けて下さい、宜しくお願いします。

Aベストアンサー

1行目はタイトル行,2行目から実データとして。
会員種別がB列に列記されているとして。
(といったような具体的なあなたのシートのレイアウトは,そもそもご相談であなたの方から提示してください)


sub macro1()
 dim h as range
 dim w as worksheet
 dim s as string
 s = activesheet.name

’転記する
 on error goto errhandle
 for each h in range("B2:B" & range("B65536").end(xlup).row)
  h.entirerow.copy destination:=worksheets(left(h, 3)).range("A65536").end(xlup).offset(1)
 next
 on error goto 0

’保存する
 for each w in worksheets
  if w.name <> s then
   w.copy
   activeworkbook.saveas filename:="c:\test\" & activesheet.name & "mm.xls"
   activeworkbook.close savechanges:=false
  end if
 next
 exit sub

’シートを新調する
errhandle:
 worksheets.add after:=worksheets(worksheets.count)
 worksheets(s).range("1:1").copy destination:=activesheet.range("A1")
 activesheet.name = left(h, 3)
 resume
end sub

1行目はタイトル行,2行目から実データとして。
会員種別がB列に列記されているとして。
(といったような具体的なあなたのシートのレイアウトは,そもそもご相談であなたの方から提示してください)


sub macro1()
 dim h as range
 dim w as worksheet
 dim s as string
 s = activesheet.name

’転記する
 on error goto errhandle
 for each h in range("B2:B" & range("B65536").end(xlup).row)
  h.entirerow.copy destination:=worksheets(left(h, 3)).range("A65536").end(xlup).offset(1)
 ...続きを読む

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

Qエクセル2007VBAで新規ファイルを作る場合

現在A社というファイルのsheet1に電気代と名前を付けたデータ、sheet2に
ガス代という名前を付けたデータがあり電気代のブックからコピーして新規ファイルに貼り付けをしたいと思い下記のとおりマクロがありますが、新規ブックを開いた時常に1ではなく他に新規ブックを開いていたら2とか3になってしまいます。すると再度新規ブックに戻ってガス代を貼り付ける時2とか3tpか4とかでしたらエラーになってしまいます。
こういう場合どのように書いたら良いのでしょうか?
それから最後に新規ファイルで名前を付けて保存のところまでダイアログ出すところまで
教えていただきたいのですが。
マクロ勉強始めたばかりでよろしくお願います。

Sub DGCopy()
Cells.Select
Selection.Copy
Workbooks.Add
Cells.Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "電気代"
Windows("A社.xls").Activate
Sheets("電気代").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book1").Activate
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "ガス代"
Application.CutCopyMode = False
End Sub

現在A社というファイルのsheet1に電気代と名前を付けたデータ、sheet2に
ガス代という名前を付けたデータがあり電気代のブックからコピーして新規ファイルに貼り付けをしたいと思い下記のとおりマクロがありますが、新規ブックを開いた時常に1ではなく他に新規ブックを開いていたら2とか3になってしまいます。すると再度新規ブックに戻ってガス代を貼り付ける時2とか3tpか4とかでしたらエラーになってしまいます。
こういう場合どのように書いたら良いのでしょうか?
それから最後に新規ファイルで名前を...続きを読む

Aベストアンサー

VBA勉強中のみだけど
Sub DGCopy2()
Sheets(Array("電気代", "ガス代")).Copy
End Sub
かな?

QVBAでアカウント名を取得する方法

VBAで処理したEXCELブックをデスクトップに自動保存しようとしています。VBAで現在作業中のユーザーアカウント名を自動で取得する方法を教えていただきたいのですが。

デスクトップ上にブックを保存するには、パスを記述すればよいのですが、現在PC毎にユーザーアカウントを設定しユーザー名が異なっています。
このため、PC毎にこのユーザー名をデスクトップへのパスに入れ込まなければなりません。毎回キーボードからこのユーザー名を入力する方法もありますが、自動的にユーザー名を取得し、正しいパスを指定する方法を検討しています。
どなたか、VBAでこのユーザー名を取得する方法が有れば教えていただきたいのですが。
よろしくお願いいたします。

Aベストアンサー

Environ関数で、環境変数[USERNAME]を取得する。

MsgBox Environ("USERNAME")

Q先般、下記のvbaのコーディング事例の回答を頂きました。

先般、下記のvbaのコーディング事例の回答を頂きました。
再度ご質問させて頂きたく、よろしくお願いします。

質問1
a列に点数を入力すると同時にb列に表示させたい。
→This workbookのPrivate Sub Workbook_Open()にvbaを登録するのでしょうか?

質問2
a列に点数が入力された場合のみb列を表示させたい。


===================
a1~a100のセルに点数が入力されているとします。
その点数を元に下記の通りb列にランクを自動的に付ける場合の
vbaのコーディングはどうなりますか?

ss(95以上)
a(90-94)
b(85-89)
c(80-84)
d(75-79)
e(70-74)
f(65-69)
g(60-64)
h(55-59)
i(50-54)
j(50以下)

Aベストアンサー

こんばんは。

こんな感じでどうでしょうか?

'シートモジュール(シートタブを右クリック--コードの表示)
'-------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Ret As Variant
  If Target.Column <> 1 Then Exit Sub
  If Target.Count > 1 Then Exit Sub
  If IsNumeric(Target.Value) = False Then Exit Sub
  Ret = RankLookUp(Target.Value)
  If Ret = 0 Then Exit Sub
  Application.EnableEvents = False
  Target.Offset(, 1).Value = Ret
  Application.EnableEvents = True
End Sub

Function RankLookUp(arg As Variant) As String
  Dim Data(10)
  Dim Chars(10)
  Dim i As Long, j As Long, k As Variant
  '除外項目
  If IsNumeric(arg) = False Then Exit Function
  If arg < 0 Then RankLookUp = 0: Exit Function
  If arg > 100 Then RankLookUp = 0: Exit Function
  
  Data(10) = 95:  Chars(10) = "ss"
  Data(0) = 0:   Chars(0) = "j"
  For i = 50 To 90 Step 5
    j = j + 1
    Data(j) = i
    Chars(j) = Chr(106 - j)
  Next i
  On Error Resume Next
  k = Empty
  k = Application.Match(arg, Data, 1)
  On Error GoTo 0
  If Not IsEmpty(k) Then
    RankLookUp = Chars(k - 1)
  End If

End Function

こんばんは。

こんな感じでどうでしょうか?

'シートモジュール(シートタブを右クリック--コードの表示)
'-------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Ret As Variant
  If Target.Column <> 1 Then Exit Sub
  If Target.Count > 1 Then Exit Sub
  If IsNumeric(Target.Value) = False Then Exit Sub
  Ret = RankLookUp(Target.Value)
  If Ret = 0 Then Exit Sub
  Application.EnableEvents = False
  Target...続きを読む


人気Q&Aランキング

おすすめ情報