特定のシートからCSVを作成するコード（その2）

こんにちは、Shigeです。
今回は、前回の特定のシートからCSVを作成するコード内のcsvシートがあるかどうかをチェックするマクロ「Sh_check_csv」をのっけます。

1. Sub Sh_check_csv()
2.     Dim ws As Worksheet, Flag As Boolean
3.     Dim newSh As String
4.     
5.     newSh = "csv"
6.     
7.     For Each ws In Worksheets
8.         If ws.Name = "csv" Then Flag = True 'csvシートがある場合、変数flagをTrueにする
9.     Next ws
10. '-------------------------------------------------
11.     If Flag = False Then
12.     ActiveWorkbook.Worksheets.Add(after:=Worksheets(Sheets.Count)).Name = newSh
13.     End If
14. '変数flagがFalseのままだったらcsvシートを追加する
15. '------------------------------------------------
16.     Worksheets(newSh).Unprotect    ' 一旦、シート保護を解除
17.     Worksheets(newSh).Visible = True
18.     Worksheets(newSh).Columns("A:A").NumberFormatLocal = "yyyy/m/d;@"
19. End Sub

そんな難しいこともないと思うので、今回も流れだけ(;・∀・)

「csv」って名前のシートを全部のシート名を検索して、あったらFlagをTrueにしてFalseのままだったらワークシートの一番最後にcsvシートを追加（15行目コメントまで）→シート保護をかけてるので解除してからA列の書式を"yyyy/m/d;@"形式にする。

どうですか？VBAをかじってれば読めるコードだと思います。
では、また。

特定のシートからCSVを作成するコード

こんにちは、Shigeです。
今回は特定のシートからcsv形式でエクスポートするコードをのっけます。

1. Sub CSVmake()
2. Dim FileN As String, strfind As String, newBook As String, ThisUser As String, PathName As String
3. Dim Re As Long, loCheck As Long
4. Dim FSO As Object
5. Set FSO = CreateObject("Scripting.FileSystemObject")
6. 
   
7. Set shKihon = Worksheets("基本情報")
8. Set ShAc = ActiveSheet
9. 'ｃｓｖシートがあるかチェック　無ければ作成
10. Call Sh_check_csv
11. Set Shcsv = Worksheets("csv")
12. '－－－－－－－－－－－－－－－－－－－－－
13. Shcsv.Cells.ClearContents   'csvシートのデータクリア
14. 
    
15. Call CSVchange(loCheck)
16. 
    
17. newBook = shKihon.Cells(1, 2).Value
18. 
    
19. If Dir("C:\csv_date", vbDirectory) = "" Then FSO.CreateFolder "C:\csv_date"
20. PathName = "C:\csv_date"
21. ChDir (PathName)
22.    
23. FileN = Application.GetSaveAsFilename(InitialFileName:=newBook, _
24.                            filefilter:="ＣＳＶ ファイル (*.csv), *.csv")
25. If FileN <> "False" Then
26.     If Dir(FileN) <> "" Then
27.         Re = MsgBox(FileN & String(2, vbLf) & _
28.                           "は、存在します。 上書きしますか？", vbYesNo)
29.         If Re = vbYes Then Kill FileN Else Exit Sub
30.     End If
31.     Shcsv.Copy
32.     ActiveWorkbook.SaveAs Filename:=FileN, FileFormat:=xlCSV
33.     ActiveWorkbook.Close Savechanges:=False
34.     Shcsv.Visible = False
35.     If loCheck = 0 Then
36.         MsgBox "CSVファイルで書き出しました。", vbInformation
37.     Else
38.         MsgBox "CSVファイルで書き出しました。" & _
39.             vbCrLf & loCheck & "件、仕訳が訂正されています。", vbInformation
40.     End If
41. End If
42. Set FSO = Nothing
43. ' シート保護を設定(UIのみ)
44. ActiveSheet.Protect UserInterfaceOnly:=True
45. End Sub

長いうえに他のコードを走らせてる部分があるので、全部解説するのが面倒だからコード書くだけにしようかな。
前回の「弥生会計形式でエクスポートするコード」と合わせると出来上がってくると思います。

まぁ、流れだけでも書き捨てしておきます。

csv用シートがあるかチェック→出納帳のデータ部分をcsv用シートに書出し+訂正仕訳があるかチェック(loCheck)→Cドライブ直下にフォルダを追加してそこにcsvを作成→確認メッセージ

とりあえず、一つ一つはそれほどのことでもないけど、組み合わせると全部解説するのは長文になりそうですね(;・∀・)

コードをまとめ終わったら、そこら辺も詳しくしていけたらと思ってます。

では、また。

弥生会計インポート形式でエクスポートするコード

こんにちは、Shigeです。
今回はコードの一部分だけのっけます。

1.     Shcsv.Cells(w, 1).Value = 2000
2.     Shcsv.Cells(w, 4).Value = ShAc.Cells(i, 1).Value '日付
3.     Shcsv.Cells(w, 17).Value = ShAc.Cells(i, 7).Text '摘要
4.     Shcsv.Cells(w, 8).Value = "対象外" '借方税区分
5.     Shcsv.Cells(w, 14).Value = "対象外" '貸方税区分
6.     Shcsv.Cells(w, 10).Value = 0 '借方消費税金額
7.     Shcsv.Cells(w, 16).Value = 0 '貸方消費税金額
8.     Shcsv.Cells(w, 20).Value = 0 'タイプ
9.     Shcsv.Cells(w, 25).Value = "no" '調整
10.     Shcsv.Cells(w, 5).Value = ShAc.Cells(i, 2).Value '借方科目
11.     Shcsv.Cells(w, 6).Value = ShAc.Cells(i, 3).Value '借方補助科目
12.     Shcsv.Cells(w, 11).Value = ShAc.Cells(i, 4).Value '貸方科目
13.     Shcsv.Cells(w, 12).Value = ShAc.Cells(i, 5).Value '貸方補助科目
14.     Shcsv.Cells(w, 9).Value = ShAc.Cells(i, 6).Value '金額
15.     Shcsv.Cells(w, 15).Value = ShAc.Cells(i, 6).Value '金額

変数のShcsvはエクスポート用にシートを作成してるので、そのシートを入れてます。

細かく解説するってほどのものでもないですけど「＝」の左側が弥生会計のインポート形式に書き出し、右側がインポートしたいデータが入力されているシートのセルを指定しているというコードになります。

ちなみに変数ｗはcsv側の行列で、変数iはデータ側の行列をforで回してます。

1. w=1
2. for i = 5 to MaxRow
3. ~
4. w= w+1
5. next i

みたいな感じですね。

あと、このコードには欠点があります。

免税なら問題ないのですけど、課税事業者の場合は消費税コードを赤文字の部分で強制的に指定しているためインポートをした後に訂正しなければいけないです。

まぁ、どうしてもインポートする時に必要なら、データ側のシートで「税区分」「消費税金額」列でも作成してもらって、「対象外」とか「0」をShAc.Cells(i,〇).valueとかで訂正するとできると思います。

では、また。

選択範囲の空白行を埋めるコード

こんにちは、Shigeです。
今回は自分で選択した範囲に空白行がある場合、空白行の上のセルの値を入れるコードです。
お客様が入力している出納帳で日付部分が同じ日の場合、空白にしている事が多々あるので、それを自動的に埋めるために作成したコードです。

1. Sub Fill()
2. Dim SetArea As Range, sel As Range
3. On Error Resume Next
4.     Set SetArea = Application.InputBox("空白を埋める範囲を選択してください", _
5.                                         "範囲選択", Type:=8)
6.     If SetArea Is Nothing Then Exit Sub
7.     
8.     For Each sel In SetArea
9.         If IsEmpty(sel) Then sel.Value = sel.Offset(-1, 0)
10.     Next sel
11. End Sub

これで範囲を選択すると空白が埋まります。

3行目 On Error Resume Next　エラーを無視するコード。

4行目でインプットボックスを表示して範囲を選択しているのですが、その時に何も選択しない時やキャンセルした場合にこの部分で処理が止まってしまうため、エラーを無視するというコードを入れています。

条件分岐させればこれを入れなくても済みますが、6行目でマクロ自体を閉じてしまうため、１行だけ書けば済むOn Errorを使ってます。

8～10行目 選択した範囲内をFor Eachで回して、空白だった場合には上のセルの値を設定してます。

数式をコピーしたい場合は.Valueを.FomulaR1C1に変更すればいける...はず！

では、また。

CSVファイルを選択してコピペする

こんにちは、Shigeです。
今回はエクセルを選択してブックに取り込むコードをのっけます。

1. Sub BookOpen()
2. Dim fname As String, Thisbook As String
3. Dim ws As Worksheet
4. Dim SetArea As Range
5. 
   
6. Thisbook = ThisWorkbook.Name '現在のブックの名前を格納
7.     Worksheets("TOP").Cells.ClearContents
8.     fname = Application.GetOpenFilename(Title:="帳簿を選択")
9.     If fname <> "False" Then
10.         Workbooks.Open Filename:=fname
11.     Else
12.         MsgBox " キャンセルしました"
13.         Exit Sub
14.     End If
15. 
    
16. Newbook = ActiveWorkbook.Name  '選択したブックの名前を格納
17.     On Error Resume Next
18.     Set SetArea = Range("A:J")
19. 
    
20.     SetArea.Copy
21.     
22.     Workbooks(Thisbook).Activate
23.     Worksheets("TOP").Cells(1, 1).PasteSpecial
24.        
25.     Application.DisplayAlerts = False
26.         Workbooks(Newbook).Close
27.     Application.DisplayAlerts = True
28.         
29.     MsgBox "コピーしたのでCSVを作成してください"
30. End Sub

では、ざっくり説明していきます。

まず、必要なシートは「TOP」というシートです。こちらは名前を「Date」とか「データ」とかシートを作成してもらえば、「TOP」の部分を変更すれば動きます。

7行目　Worksheets("TOP").Cells.ClearContents　「TOP」シートのデータをクリアする

説明としては上の「クリアする」で十分だと思うのですが、なんで消すのかというと基本的にこのコードを使う時には「取込したいエクセル」っていうのが決まっていて、それ以外のデータは入っていてほしくない為、最初にデータを消しています。

8～14行目は取込したいエクセルを選ばせるダイアログを表示させます。

16行目　Newbook = ActiveWorkbook.Name  '選択したブックの名前を格納

6行目を飛ばしましたが、なんでブックの名前を格納しているのかは、エクセルのブックを新規に開くとその開いたエクセルがアクティブ（選択した状態）になる為、貼り付けたいエクセルに戻るためには、戻りたいエクセルの名前を格納しておくとWorkbooks(〇〇).Activateでどちらのブックも選択することができます。

18行目　Set SetArea = Range("A:J")　コピーしたい列を格納（Range型）

23行目　Worksheets("TOP").Cells(1, 1).PasteSpecial　TOPシートに貼付

26行目　Workbooks(Newbook).Close　選択したエクセルを閉じる

とりあえず赤文字のところを変更すれば理屈は抜きに使用できると思います。

もちろん、この単体のコードだけではコピペするのみですので、「その先」に行くためには独自のコードが必要になりますが、コンバーターを作成する上での導入部分はこちらでいいんじゃないでしょうか。

では、また。

よく使う変数

こんにちは、Shigeです。
前回コードをアップして思ったのが、いきなりコードだけあっても最終行取得の変数とか、アクティブシートを入れとく変数とかよく使っているものがあるので、今回はそれをまとめとこうと思います。

• MaxRow→Long（数値型）　Cells(Rows.Count, 1).End(xlUp).Row

Rows.Countで「最終行」、その後の1(A列)が最終行を調べる対象の「列」を指定しています。なので1の部分を変えれば調べたい列の最終行がMaxRowに格納されます。

ちなみに、空白行があっても一番下の行を調べられるので、調べたい列が変わらない場合にはこの方法で十分だと思ってます。

• sh～→Worksheet型　　例：Set ShAc=ActiveSheet　,　Set ShCsv =Worksheets("csv")

Worksheet型の変数を格納するには"Set"を使わないといけないです。アクティブなシートだったら”ActiveSheet”と指定すればOKなので簡単ですね。

よく使うと言いながらざっと見これだけしかないという残念な感じですが、これからアップしていく中できっと？このページに追加していく変数があるはず！と思う。多分...。

今回は詳細なコードをのっけているわけではないのですが、ほぼ毎回出てくると思うので次回からここに挙げたものについては、説明したりしないつもりです。

では、また。

アクティブなシートから「リスト」シートへまとめる

こんにちはShigeです。
このマクロは弥生会計等のコードが出ないソフトからコードで取込をする時に、勘定科目のリストを作成するものになります。

1. Sub M_Make_List()
2. Dim Dic, i As Long, buf As String, Keys
3. Dim MaxRow As Long
4. Dim shList As Worksheet
5.     Set Dic = CreateObject("Scripting.Dictionary")
6.     Set shList = Worksheets("List") 'Listシートをまとめるシートに指定
7.     MaxRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row  'アクティブなシートの最終行を取得
8.     For i = 1 To MaxRow　
9.         buf = Cells(i, 3).Value　'リストを作成したい列の選択
10.         If Not Dic.Exists(buf) Then
11.             Dic.Add buf, buf
12.         End If
13.         Cells(i, 2).FormulaR1C1 = "=VLOOKUP(RC[1],List!C[-1]:C,2,FALSE)"
14.     Next i
15.     ''出力
16.     Keys = Dic.Keys
17.     For i = 0 To Dic.Count - 1
18.         shList.Cells(i + 2, 1) = Keys(i)
19.     Next i
20.     Set Dic = Nothing
21. End Sub

ではこれだけは必須というものをあげていきます。
6行目に変数「shList」に「List」シートをセットしているので、この名前のワークシートを用意してください。
これだけ(*'▽')
基本、このワークシートとまとめたいワークシートが用意してあればこのマクロは動きます。
といってももちろんこれだけでは、希望の部分を抽出できないと思われるので、条件に合わせる部分も注釈していきます。
7行目　MaxRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row　最終行取得
「1」の部分を変えてください。どうかえるのかは先輩諸氏の解説サイトを見ていただくか、その内当サイトでも基本の部分は書くことなくなったら書くことになるかも（おい）
9行目　buf = Cells(i, 3).Value　リストを作成したい列
「3」の部分を変えてください。どう変え・・(/・ω・)/