ExcelVBA 名簿の別ブック（CSV)へコピーについて

質問

VBAは学生時代勉強したもののすっかり忘れてしまい、初心に返って現在参考書を読みながら取り掛かっていますが、
望むような動作が出来ず大変困っています。下記のようなデータを新規ブックAへある条件でコピーし、
CSVとして保存したく、試行錯誤中です。
（A:1）（G:15）までタイトル行にあったデータが入っている名簿があります。
（G:15）でデータは終了ですが、別の名簿も扱う事があり、別の名簿はデータの終了行は（G:15）とは限りません。
--------------------------------------------------------------
（A列）（B列）　（C列）　（D列）　（E列）　（F列）　（G列）
　No 　　姓　　　 名　　姓カナ　　名カナ　 年齢　 性別
　1
　2
　3
　・
　15
　空白　 空白　 空白　 空白　 空白　 空白　 空白
--------------------------------------------------------------
コピー条件
(1)データの開始行検索＆終了行検索（空白セル）
(2)データ内の検索（文字or数字）
(3)データの開始行から終了行まで新規ブックAへ下記を繰り返す
(4)A列のデータを新規ブックAへコピー
(5)タイトル行のデータ入力（A列：同じ）（B列：名前）（C列：カナ）
(6)B列＋全角スペース＋C列のデータを新規ブックAのB列へコピー
(7)D列＋半角スペース＋E列のデータを新規ブックAのC列へコピー
(8)G列のデータを新規ブックAのD列へコピー
(8)F列のデータを新規ブックAのE列へコピー
(9)新規ブックを本ファイル名＋YYYYMMDD.csvでデスクトップへ保存
--------------------------------------------------------------
図々しい質問ですが、具体的なコードのお知恵をお貸し頂けたら大変助かります。どうぞ、よろしくお願いいたします。

回答No.3

cj_mover

誤＞fnNEW=S_DSKTOP & "\" & ActiveSheet.Parent.Name & "YYYYMMDD" & ".xls"
正しくは、
fnNEW=S_DSKTOP & "\" & ActiveSheet.Parent.Name & "YYYYMMDD" & ".csv"
以上訂正です。失礼しました。

"YYYYMMDD"の処はFormatなんでしょうけれど、「何を？」がわからないので省略。

普通にテキストで出力しても良さそうですよね。

検索の意味が、データ型のことならVarTypeとかで判別して、
文字列なら""を付加したり、
シリアル値なら"YYYYMMDD"にFormatしたり、
そんなことかな？

一応、応用可能にはなってるので、私はここまでにします。

補足

度々申し訳ありません。折角上記を教えて頂いたので、自分なりに教えて頂いたコードの意味を調べながら、
繰り返し処理に追加したいと思いコードの加筆を実施しているのですが、ReDim関数の意味が中々理解出来ず、
再度アドバイス頂けらと思いまして。実は上記質問のファイルには
下記のようなデータが続いております。
--------------------------------------------------------------
（A列）（H列）　　（I列）　　　　（J列）　　　　（K列）　　　（L列）
　No 　　〒　　　 都道府県　　市区町村　　番地　 　アパート名
　1
　・
　15
　空白　 空白　 空白　 空白　 空白　 空白
--------------------------------------------------------------
上記H列からL列のデータも、新規ブックのF列に元データの
H列のデータをコピー、新規ブックのG列に元データの
I列のデータをコピー、と繰り返し処理で行いたく。
そこで大変お手数なのですが、ReDim以降のコードの解説をいただけると大変有難いです。
度々申し訳ありませんが、お知恵を貸して頂けないでしょうか？

回答No.2

cj_mover

想像で書いているので違うのでしょうし。
自分が書き易いように書いただけなのであまり参考にならないでしょうけど、
ここがニーズと違うとかの叩き台としてどうぞ。

以下、ActiveSheet(ワークシート)専用、
標準モジュール、XL2000～2003で動作、OSはXP

Option Explicit
Sub test()
Dim vA, vAP, sA
Dim i As Long, ub As Long
Dim fnNEW As String
' 以下１行、適宣、デスクトップを指定
Const S_DSKTOP = "C:\Documents and Settings\user\デスクトップ"

fnNEW = S_DSKTOP & "\" & ActiveSheet.Parent.Name & "YYYYMMDD" & ".xls"
vA = Cells(2, 1).CurrentRegion.Resize(, 7).Value

ub = UBound(vA)
ReDim vAP(1 To ub, 1 To 5)
sA = Split(" No. 名前 カナ 年齢 性別")
For i = 1 To 5
vAP(1, i) = sA(i)
Next i
For i = 2 To ub
vAP(i, 1) = vA(i, 1): vAP(i, 4) = vA(i, 6): vAP(i, 5) = vA(i, 7)
vAP(i, 2) = vA(i, 2) & "　" & vA(i, 3): vAP(i, 3) = vA(i, 4) & " " & vA(i, 5)
Next i
With Workbooks.Add(xlWBATWorksheet)
.Worksheets(1).Cells.Resize(ub, 5).Value = vAP
.SaveAs fnNEW, xlCSV
End With
End Sub

お礼

大変詳しく具体的にコードを記載頂いて、どうもありがとうございます！！
自分が行いたかった事が実現できました！叩き台なんてとんでもなく、
完成版として満足に利用できそうです。

また、XLのバージョンやOSも記載いただき、ありがとうございます。
質問している私側がまず提示すべき情報でしたのに・・・。
私もXLが2003でOSもXPですので問題なく作動できました。
記載頂いたコードをきちんと把握できるよう勉強していきます。
本当に大変助かりました。どうもありがとうございましたm(_ _)m

回答No.1

hotosys

こんなのではどうでしょうか？
どんな検索をするのかわからないのですが・・・
文字の場合"山*"とか"*山"とか"*山*"で、部分一致の検索ができます。
.AutoFilter Field:=2, Criteria1:="*山*" '姓
.AutoFilter Field:=6, Operator:=xlAnd, Criteria1:=">=20", Criteria2:="<30" '年齢範囲(複合条件）（20代）
.AutoFilter Field:=7, Criteria1:="女" '性別
とすれば「苗字に山が付く20代の女性」と言う検索ができます。
Sub sample()
'オートフィルタで検索
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
Dim filterCount As Long
Set srcSheet = Sheets("Sheet1") '元データがあるシート
If srcSheet.AutoFilterMode = True Then srcSheet.AutoFilterMode = False
With srcSheet.Columns("A:G")
'データ内の検索
'.AutoFilter Field:=2, Criteria1:="" '姓
'.AutoFilter Field:=3, Criteria1:="" '名
'.AutoFilter Field:=4, Criteria1:="" '姓カナ
'.AutoFilter Field:=5, Criteria1:="" '名カナ
'.AutoFilter Field:=6, Criteria1:=20 '年齢
'.AutoFilter Field:=6, Criteria1:=">=65" '年齢範囲
.AutoFilter Field:=6, Operator:=xlAnd, Criteria1:=">=20", Criteria2:="<30" '年齢範囲(複合条件）
.AutoFilter Field:=7, Criteria1:="" '性別
filterCount = srcSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count
If filterCount = 1 Then
MsgBox "データ無し"
Exit Sub
End If
End With
'以下の整形と保存部はあまり一般的ではないかも
With Worksheets.Add
'検索結果を新しいシートに転記
srcSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy Destination:=.Range("A1")
'整形
.Range("H1").Resize(filterCount, 1).Formula = "=B1&""　""&C1"
.Range("I1").Resize(filterCount, 1).Formula = "=D1&"" ""&E1"
.Range("J1").Resize(filterCount, 1).Formula = "=G1"
.Range("K1").Resize(filterCount, 1).Formula = "=F1"
.Columns("H:K").Copy
.Columns("H:K").PasteSpecial Paste:=xlPasteValues
.Columns("B:G").Delete
.Range("B1:C1").Value = Array("名前", "カナ")
'シートを新しいブックに移動
.Move
'新しいブックを保存
ActiveWorkbook.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Now(), "YYYYMMDD"), FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
End With
End Sub

お礼

大変詳しくコードを記載頂き、ありがとうございました。
私が詳しく検索に関する条件等を記載しなかったので申し訳ありませんでしたが、
幅広い検索ニーズに対応できる具体的コードを記載いただき、
こんな事も出来るのか、と脱帽しました。

今回私が行いたい作業とは少々違いましたが、今後やりたいと思っていたい事でしたので、とても有難いです！
上記を理解するためには自分がもっと勉強しないとな、と実感いたしました。
本当にお知恵を貸していただき、どうもありがとうございました。
是非とも参考にさせて頂き、自分でも教えて頂いたコードを把握できるよう勉強していきます。