自作関数 列を英字で求める。
１ 閲覧対象者
列を英字で取得したい人。
２ 得られる効果
VBAで数式を直接代入する際に楽になる。
３ 設計
解析中ｗ
以下コード↓↓
Public Function CnvR1C1(ByRef CellColumnNo As Integer) As String Dim Syo As Integer Dim Amari As Integer Dim Str1 As String Dim Str2 As String If CellColumnNo > 256 Then Exit Function End If Syo = CellColumnNo \ 26 Amari = CellColumnNo Mod 26 If Syo > 0 Then If CellColumnNo > 26 And Amari = 0 Then Str1 = Chr(Syo - 1 + 64) Else Str1 = Chr(Syo + 64) End If If Amari > 0 Then Str2 = Chr(Amari + 64) Else Str2 = Chr(90) End If Else Str1 = Chr(Amari + 64) End If CnvR1C1 = Str1 & Str2 End Function
４ 使用例
以下の画像の通り、行数の英字を返します。
使いどころは、VBAで数式を直接代入するときです。
For k_row = 6 To 7 For k_col = 3 To 14 myCol = CnvR1C1(k_col) ActiveSheet.Cells(k_row, k_col) = "=IF(ISERROR(A売上!" & myCol & k_row & "/B売上!" & myCol & k_row & "),"""",A売上!" & myCol & k_row & "/B売上!" & myCol & k_row & ")" Next Next
この例は、Cのシートの合計数値が、Aシート/Bシートの値になっています。
A,Bそれぞれのシートの値を持ってきたかったので、この関数を使ってみました。
変数myColに列数を求めています。
ちなみに「３～１４」なので、列C～列Nです。
５ 感想
この例は「同じテンプレートのExcelで項目が違うシート」という前提があります。
なので、各シートの同じ場所を参照すればいいのです。
しかし、数式を直接代入しようとすると、列の英字を求めることがネックになると思ったので使ってみました。
使い勝手は良いと思います。
ちなみに、コードの中身はわかっていません(;^ω^)
使えると思ったらご自由にどうぞ！
ではでは、この辺で(@^^)/~~~
VBA 若い番号順に並べ替え
１ 閲覧対象者
製品データ等を、若い番号順に並べ替えたい人。
２ 得られる効果
帳票作成時の並べ替えで、製品番号順に処理ができる。
DIctionaryの機能を多少理解できる。
３ 設計
以下のような製品No順に並べ替えてあるデータがあります。これを右のように若い番号順に並べ替えって通常の並べ替え機能では作成不可能です（ワイが知らないだけ！？）。
この場合、別の列に製品名の若番号を振る（列F）必要があります。
この「若番号を振る」処理をDIctionaryを使ってやってみます。正直、2次元配列を使えば済む話なんですが、あえてDIctionaryを使ってみます。この方が処理が早いらしいのです。
今回は簡単な例で、データ少ないのでなんとも言えませんが(;^ω^)とりあえずやってみましょう。
写真データの製品Cに注目してください。データの若番号順に並べ替えるということは、製品C４つのデータに対して若番号である「268」を振る必要があります。その処理をDIctionaryを使って実装します。
列Fに各製品に対する若番号を付与し、最後に若番号（列F）、製品名（列D）で並べ替えます。
４ コードの解説
Sub Sort_dict() Rem 若番号順に製品名を並べ替える。（データが、製品Noの昇順で並べ替えられていることが前提） Dim sh As Worksheet Dim cr As Range Dim k_cr Dim myDict_YoungNo Set myDict_YoungNo = CreateObject("Scripting.Dictionary") Set sh = Worksheets("Sheet3") Set cr = sh.Range("A1").CurrentRegion.Resize(, 6) '製品名の若番を求める。 On Error Resume Next For k_cr = 2 To cr.Rows.Count myDict_YoungNo.Add cr.Cells(k_cr, 4).Value, cr.Cells(k_cr, 3).Value Next On Error GoTo 0 '列に若番を追加 For k_cr = 2 To cr.Rows.Count cr.Cells(k_cr, 6) = myDict_YoungNo(CStr(cr.Cells(k_cr, 4))) Next '若番順に並べ替え cr.Sort key1:=Range("F1"), key1:=Range("D1"), Header:=xlYes End Sub
解説
まず、列Fに転記できるように変数crはResize(, 6)でsetします。次に、DIctionaryの「myDict_YoungNo」のkeyに製品名、itemに製造番号を加えます。
keyに重複した値を入れることはできないので、製品Noで並べ替えられたデータであるということが前提です。必要であれば処理の追加をします。
これで製品名ごとの若番号がmyDict_YoungNoに取得することができました。
次に、列Fに若番号を代入します。
これはcrをループします。製品名をKeyとして、対象の連想配列のItemが代入されます。
最後に、並べ替えします。
key1=若番号、key2=製品名です。
すると、以下の図のとおり若番号順に並べ替えることが可能です。
５ 感想
帳票作成業務では、既存処理の改修依頼が多いです。今回の場合は、転記の順番で製品名が複数あった場合、先に転記してほしい（若い番号順に処理）というものでした。
並べ替えで解決することは割と多いので知っておくと便利かもです。
ではでは、このへんで(^^)/~~~
FSOで、ディレクトリ内のBookのSheetを一つのBookにまとめる。
仕事の依頼は突然に…
全く関係ない。全く関係ない業務の方からこんな依頼されました。「このBookのSheetをさぁ～、集計.xlsxにまとめるマクロ作れる？」。正直、かったり～なぁ～、俺の業務じゃないしと思いながらもFSOの復習がてら作ってみました。
１ 閲覧対象者
FSOを使って、たくさんのBookのSheetを1つのBookにまとめたい方。
例↓↓
今回は、集計.xlsxに店舗A～店舗CのBookのSheetをまとめます。前提として店舗Bookには「１Sheet」のみの想定です。）
２ 得られる効果
作業がしやすくなる…でしょうか(;^ω^)
正直、Bookが重たくなるので便利かどうかはよくわかりません。
３ 設計
１つのディレクトリにある「集計.xlsx」に店舗A～店舗CのBookのSheetをまとめます。
各店舗Bookには以下の様に、売上Sheetが入っています（１Sheetのみ）。
実行前集計.xlsx↓↓
集計に各BookのSheetをまとめる.xlsmのマクロ実行後の集計.xlsx↓↓
店舗A、店舗B、店舗CのSheetが追加されています。
また集計.xlsxのBackUpファイルも取っておきます。
４ コードの解説
集計に各BookのSheetをまとめる.xlsmのコードを見ていきましょう。
Sub すべてのファイルに値を代入() 'FSOを宣言 Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject") Dim tgt_wb As Workbook Dim wbPath Dim myfiles, file Dim shName Application.ScreenUpdating = False 'pathの設定 wbPath = ThisWorkbook.Path Set tgt_wb = Workbooks.Open(wbPath & "\集計.xlsx") 'BackUp If Not fso.FileExists(wbPath & "\bk_集計.xlsx") Then ActiveWorkbook.SaveAs Filename:= _ wbPath & "\bk_集計.xlsx", FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False ActiveWorkbook.Close Set tgt_wb = Workbooks.Open(wbPath & "\集計.xlsx") End If Set myfiles = fso.getfolder(wbPath).Files For Each file In myfiles If Not file.Name Like "~$*" Or file.Name Like ".xlsx" Then If Not file.Name Like "*集計*" Then Debug.Print fso.getbasename(wbPath & "\" & file.Name) shName = fso.getbasename(wbPath & "\" & file.Name) Call OpenBooks_String(wbPath & "\" & file.Name) 'sheetのコピー ActiveSheet.Name = shName Sheets(shName).Copy after:=tgt_wb.Sheets(tgt_wb.Sheets.Count) Call CloseBooks_Sring(file.Name) End If End If Next '小計.xlsxを保存して閉じる。 tgt_wb.Save tgt_wb.Close End Sub
サブルーチン１
Sub OpenBooks_String(ByVal mypath As String) Workbooks.Open mypath End Sub
サブルーチン２
Sub CloseBooks_Sring(ByVal myName As String) Dim wb As Workbook Set wb = Workbooks(myName) wb.Close (False) 'True=保存して閉じる。False＝保存しないで閉じる。 End Sub
コードの説明
１ 集計.xlsxのBackUpを取ります。すでに、bk_集計.xlsxが存在する場合は処理しません。
２ ファイルの数だけループ処理します。この時の注意点は、ファイル名に集計の文字列が入っている場合は処理ません。処理の対象は店舗Bookとなります。
３ Sheet名ををgetbasenameで取得します（拡張子を除いたファイル名）。集計.xlsxコピーします。
４ Bookを保存せずに閉じて、次のBookを処理する。
以上、１～４の繰り返しとなります。エクセルで使用できるメモリの限りSheetを作成できます（PCのメモリに依存する）。
５ 感想
FSOって使わないと忘れるので、今後こういう場面に出くわしたらコピッペで使おうと思います。
いい練習になりました。
ではでは、この辺で(^^)/~~~
ExcelVBAで、ビンゴツールを作った。
忘年会で幹事やります(´;ω;｀)
2021年年末、コロナが落ち着いているとはいえ、まだ対面での忘年会はやりにくいですね。なので、Zoom会です。
忘年会で幹事をやることになりました。忘年会の定番イベントとして「ビンゴ大会」をやるのは会社の定番ではないでしょうか。
んで、ビンゴやるにあたってネットで無料ツール探すのですが、機能としては番号出すだけのものが多い印象でした。つまり確認作業はアナログです。
聞くところによると、Zoom会でビンゴをやって2時間かかったそうです(;^ω^)
これ聞いて、時間の無駄やろ！というのが私の感想です。なので、ビンゴツールを作りました。作成期間は、１日です。
１ 閲覧対象者
Zoom会等、画面共有できる環境でビンゴ大会をやる人。
デザインより時間効率を優先する人。
２ 得られる効果
ビンゴ大会の時間短縮。
出目の確認、ビンゴ者の判断を自動化。
ネットに転がっているビンゴツールは３０人以上だと有料になったり、ブラウザのセッションを切ると別のビンゴカードが作成されて管理しずらいので、その辺の制限からの開放。
３ 設計
使うSheetは上の画像の通り、４Sheetです。
１ Sheet1 ビンゴカード作成用のテンプレートです。
２ 参加者Sheet 参加者を列Aに書き込みます。参加者の分Sheetを作成します。
３ 回すSheet 出目を出します。また、出た出目を転記します。
４ 景品Sheet 景品を書き込みます。このSheetには特に何もしません。景品を書いて誰が当たったのか転記するのはマニュアルです。
（注）参加者の人数分Sheetを作成するので、人数制限としては作成できるSheet数となります。PCのメモリに依存しますが、100人くらいは余裕だと思います。
仕様
参加者の数だけ、ビンゴカード（Sheet）を作ります。また、PDFで保存します。
（作成したビンゴカードPDFは、ZoomのチャットにUPして各人に開いてもらいます。）
上の画像が、回すSheetです。こいつがメインのSheetです。
出目を出すをクリックします。赤色のセルに乱数で出目を出します。出た出目は、薄い緑のセルに転記します。端の右下が黒いのは１～９９までの数字を使うからです。
出目を出したら、各人のビンゴカードに該当するかチェックします。該当すれば、セルを黄色に塗ります。
その後、ビンゴ者がいるかチェックします。
最後に、メッセージで誰のマスが開いたのか、誰がビンゴになったのかを出します。
イメージ
ビンゴ開始↓↓
参加者5名のシートができていますね。
参加者のSheet↓↓
出目を出すをクリック↓↓
赤色のセルに出目が出ます。また誰が当たったのかをメッセージで知らせてくれます。
参加者３のSheetの8番セルが黄色に塗りつぶされています。
ビンゴを通知（ここではいじってます(;^ω^)）↓↓
４ コードの解説
まず、ビンゴカードを作ります。
以下のコードをご覧ください。
１ ビンゴカード作成する「make_bingoCD」
Sub make_bingoCD() Dim arrUnique Dim cr As Range Dim shName Dim i, j, e Dim sh_participant As Worksheet: Set sh_participant = Worksheets("参加者") Dim cenCnt, arrIX Dim wrNo Dim noFlg As Boolean Dim filePath Application.ScreenUpdating = False Randomize '名前の数だけSheetを作成してカードを作る For i = 1 To sh_participant.Cells(Rows.Count, 1).End(xlUp).Row shName = "CD_" & sh_participant.Cells(i, 1) Worksheets("Sheet1").Copy after:=Worksheets(Worksheets.Count) ActiveSheet.Name = shName Set cr = Range("B3:F7") arrUnique = Array() cenCnt = 0: arrIX = 0 '乱数を代入処理 For Each e In cr cenCnt = cenCnt + 1 If cenCnt = 13 Then 'pass Else wrNo = Int(Rnd * 100) If LBound(arrUnique) = 0 Then '１回目が0の場合、0以外なるまで作成。 If wrNo = 0 Then Do wrNo = Int(Rnd * 100) Loop Until wrNo <> 0 End If arrIX = arrIX + 1 ReDim arrUnique(1 To arrIX) arrUnique(arrIX) = wrNo e.Value = wrNo Else Do Until noFlg = True For j = LBound(arrUnique) To UBound(arrUnique) If wrNo = arrUnique(j) Or wrNo = 0 Then wrNo = Int(Rnd * 100) '乱数の作成 j = 1 Exit For End If If wrNo <> arrUnique(j) Then If j = UBound(arrUnique) Then arrIX = arrIX + 1 ReDim Preserve arrUnique(1 To arrIX) arrUnique(arrIX) = wrNo e.Value = wrNo noFlg = True Exit For End If End If Next Loop noFlg = False End If End If Next 'PDFで保存 filePath = ThisWorkbook.Path & "\" & sh_participant.Cells(i, 1) & "さん_BINGOカード" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ filePath, Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Next Worksheets("回す").Select End Sub
必要な仕様としては、乱数で番号が被ってはいけません。なので、出目を変数arrUniqueに記憶します。出目の変数wrNoと被って無ければSheetに書き込みます。その後PDFを作成する（配布用）。
この処理を、参加者人数分処理します。
では、ビンゴカードができたところでビンゴ開始です。出目を出すコードを見ていきましょう。
２ 出目を出し、該当番号、ビンゴ者のチェック「出目」
Sub 出目() Dim sh As Worksheet: Set sh = Worksheets("回す") Dim arrNo, arrRng As Range Dim roll Dim i, j, e Dim noFlg As Boolean, noFlg2 As Boolean Dim che_sh Dim che_cr Dim tgt_cr As Range Dim strFindRoll Dim strReach Dim strBINGO Dim bingo_cr Randomize roll = Int(Rnd * 100) sh.Range("C4") = "" arrNo = sh.Range("J2:S12") Set arrRng = sh.Range("J2:S12") '重複しない出目を決定。 Do Until noFlg = True If sh.Range("R11") <> "" Then MsgBox "1～99のすべての数値が出力されました。": Exit Sub For i = LBound(arrNo) To UBound(arrNo) For j = LBound(arrNo, 2) To UBound(arrNo, 2) If roll = arrNo(i, j) Or roll = 0 Then roll = Int(Rnd * 100) '乱数の作成 i = 1 j = 1 noFlg2 = True Exit For End If If roll <> arrNo(i, j) Then If i = UBound(arrNo) And j = UBound(arrNo, 2) Then For Each e In arrRng If e = "" Then 'Call ドラムロール音 'Application.Wait (Now + TimeValue("00:00:06")) sh.Range("C4") = roll e.Value = roll Exit For End If Next noFlg = True Exit For End If End If Next If noFlg2 = True Then Exit For Next If noFlg2 = True Then noFlg2 = False Loop '出目に対する各Sheetのチェック処理 For Each che_sh In Worksheets If che_sh.Name Like "CD*" Then Set tgt_cr = che_sh.Range("B3:F7") For Each che_cr In tgt_cr If che_cr = roll Then che_cr.Interior.ColorIndex = 6 'セルを黄色に塗る '当たった人の名前 If strFindRoll = "" Then strFindRoll = roll & "番で" & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さんのマスが開きました" Else strFindRoll = strFindRoll & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さんのマスが開きました" End If Exit For End If Next End If Next '再計算 Application.Calculation = xlCalculationAutomatic Application.Calculate 'ビンゴになった人、出目が当たった人を表示 For Each che_sh In Worksheets If che_sh.Name Like "CD*" Then '斜めのビンゴを求める che_sh.Range("H2") = CHeck_Bingo(che_sh.Range("B3,C4,D5,E6,F7")) '右下 che_sh.Range("H8") = CHeck_Bingo(che_sh.Range("B7,C6,D5,E4,F3")) '右上 '縦ビンゴを求める che_sh.Range("B9") = CHeck_Bingo(che_sh.Range("B3:B7")) che_sh.Range("C9") = CHeck_Bingo(che_sh.Range("C3:C7")) che_sh.Range("D9") = CHeck_Bingo(che_sh.Range("D3:D7")) che_sh.Range("E9") = CHeck_Bingo(che_sh.Range("E3:E7")) che_sh.Range("F9") = CHeck_Bingo(che_sh.Range("F3:F7")) '横ビンゴを求める che_sh.Range("H3") = CHeck_Bingo(che_sh.Range("B3:F3")) che_sh.Range("H4") = CHeck_Bingo(che_sh.Range("B4:F4")) che_sh.Range("H5") = CHeck_Bingo(che_sh.Range("B5:F5")) che_sh.Range("H6") = CHeck_Bingo(che_sh.Range("B6:F6")) che_sh.Range("H7") = CHeck_Bingo(che_sh.Range("B7:F7")) Set bingo_cr = che_sh.Range("B9:F9, H2:H8") For Each e In bingo_cr 'リーチの表示 If e.Value = 26 Then If strReach = "" Then strReach = Replace(che_sh.Name, "CD_", "") & "さん、リーチ！" Else strReach = strReach & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さん、リーチ！" End If End If If e.Value = 30 Then 'ビンゴの表示 If strBINGO = "" Then strBINGO = roll & "番で" & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さん、BINGO！" Else strBINGO = strBINGO & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さん、BINGO！" End If 'Sheet名を"済"を加える。 che_sh.Name = "済_" & che_sh.Name Exit For End If Next End If Next 'メッセージ表示 If strFindRoll <> "" Then Call マスが開く音 Application.Wait (Now + TimeValue("00:00:01")) MsgBox strFindRoll End If If strReach <> "" Then Call リーチ音 Application.Wait (Now + TimeValue("00:00:01")) MsgBox strReach End If If strBINGO <> "" Then Call ビンゴ音 Application.Wait (Now + TimeValue("00:00:01")) Call 歓声音 MsgBox strBINGO End If End Sub
ここでも、重複の出目はダメです。回すSheetのRange("J2:S12")を変数arrNoに代入して、重複した場合、乱数を取り直します（変数roll）。
晴れて重複してない、乱数が取得できたら、回すSheetの薄い緑に転記します。その後、各個人Sheetに該当の番号があるかチェックします。
当たった人の該当セルを黄色で塗りつぶします。
また、リーチの人がいたらMsgboxでお知らせする。BINGOの人がいたら、Msgboxでお知らせします。
次に、ビンゴ者のチェックをします。これには以下のFunctionを使います。
Function CHeck_Bingo(tgt_cells As Range) Dim myRng Dim colorNo: colorNo = 0 For Each myRng In tgt_cells colorNo = colorNo + myRng.Interior.ColorIndex ' 背景色 Next CHeck_Bingo = colorNo End Function
要は、縦、横、斜めの塗りつぶされた色の合計が30であればビンゴです。
メッセージ用の変数strFindRoll、strBINGOが空白でなければメッセージを表示します。
ちなみに、ビンゴになった人のSheet名は頭に「済_」を付けるので、ビンゴになった後は、出目のチェック対象にはなりません。
こんなところです。
５ 備考
ビンゴカードのSheetをすべて削除したい場合は以下のマクロを実行します。
Sub Sheet_Delete() Dim sh As Worksheet Dim e Application.DisplayAlerts = False For Each e In Worksheets If e.Name Like "*CD_*" Then e.Delete Next End Sub
これでカードを作り直すのが簡単たんです。
PDFはマニュアルでけしてくださいm(_ _"m)
６ 感想
乱数を2回作っているコード部分を不思議に思った人もいるかもしれません。この理由は、乱数の１回目がほぼ１００％「７０」になるんです(;^ω^)
仕様なのかはわかりませんが、気になったので２回乱数を取っています。
このくらいのお遊びツールを作れるエクセルVBAは素晴らしいですね。
追記
乱数の１回目がほぼ１００％「７０」になる理由は、Randomizeで「乱数テーブル」を初期化していなかったためとのご指摘いただきました。
コードにも反映しております。
【配列の次元数を調べるFunction】
１ 閲覧対象者
配列の引数から、配列の次元数を取得するコードを知りたい方。
２ 得られる効果
配列の次元数を取得するFunctionの作成方法が分かる。
配列の最大次元数がわかる（60次元）｛別に分らんでもいい。使わないｗ｝。
３ 設計
Subプロシージャから、Function「配列の次元数」を呼び出し、配列の次元数をイミディエイトウィンドウに出力する。
４ コードの解説
実際のコード↓↓
Option Explicit Sub 配列の次元数を調べる() Dim arr1(1 To 3) Dim arr2(1 To 2, 1 To 4) Dim arr3(1 To 2, 1 To 4, 1 To 5) Dim x x = 配列の次元数(arr1) Debug.Print "arr1", x x = 配列の次元数(arr2) Debug.Print "arr2", x x = 配列の次元数(arr3) Debug.Print "arr3", x End Sub
Function 配列の次元数(a_arr) Rem 配列の次元数は、最大６０次元 Rem 各次元の下限要素をLbound(a_arr,n)とすると、その次元が無ければ例外が発生する（on Error gotoでトラップする） Rem つまり、1次元から61次元まで下限を取得し、エラーになれば終了。 Dim x, i On Error GoTo Error_Handler00 For i = 1 To 61 'to 61にしておけば、必ず例外が発生する。 x = LBound(a_arr, i) Next Exit Function Error_Handler00: 'Fuctionの戻り値は関数名に代入する。 配列の次元数 = i - 1 End Function
処理結果
解説
プロシージャ「配列の次元数を調べる」の中で、単純に1次元配列～3次元配列（arr1～arr3）を作成しています。
各arrを、Function「配列の次元数」に渡して、次元数を調べます。
For文で「i」を回して、LBoundで次元があるか調べます。あればループ継続。無ければ、Error_Handler00に処理が飛びます。
配列の次元数は、「i - 1」となります。
ちなみに、For i = 1 To 61 とすることで、61次元目に到達すればError_Handler00に処理が飛びます（配列の限界値60に到達）。
５ 感想
これで簡単に、配列の次元数を調べることができます。VBA使う仕事してますが、次元数を調べるコードを書いたことがなかったです。設計で決めるものかと思っていました。需要があるかどうかはわかりませんが、勉強になりました。
ではでは、このへんで(^^)/~~~
CSVデータの数値の罠
CSVファイルのデータを取り込む
以下の画像の通り、「製品データ.csv」と「製品データ取得.xlsm」の２つのファイルがあります。
CSVファイルの中身↓↓
何の変哲もない、４行のデータです。
CSVファイルを開いてデータを取得する。
以下のコードでCSVファイルを開いてデータを取得します。
Sub csvをOpenしてデータを取得する() Dim fPth Dim wb fPth = ThisWorkbook.Path & "\製品データ.csv" Set wb = Workbooks.Open(fPth) Range("A1").CurrentRegion.Copy wb.Close Range("A1").Select ActiveSheet.Paste Range("A1").Select Columns("A:C").AutoFit Set wb = Nothing End Sub
処理結果↓↓
CSVデータが取得できたように思えますね！
しかし、これ間違っています。
では、何が違うのか？
このCSVファイルを、「テキスト」で開いて見てみましょう！
（右クリック → プログラムから開く → メモ帳）
すると、以下の画像の通り↓↓
なんということでしょう！？４行目のシリアル番号は「００３２」なのです！
これはおそらく、CSVファイルをExcelで開くと自動変換しているものと思われます。
ニャンちゅうこっちゃ(;^ω^)
どうしようもないのか！？
こんなときのための対処法を紹介します！
テキストでファイルを開く
テキストベースでファイルデータを取得します。
シリアル番号の列が数値の場合「’」（シングルクオート）を付けてファイルを上書きします。
コードは以下の通り↓↓
Sub csvをテキストで開く() Dim i, j Dim fPth Dim Fno Dim data() As String Dim rec Dim fCnt Dim svData(1 To 4) fPth = ThisWorkbook.Path & "\製品データ.csv" Fno = FreeFile Open fPth For Input As #Fno While Not EOF(Fno) Line Input #Fno, rec data = Split(rec, ",", -1) fCnt = fCnt + 1 If IsNumeric(data(2)) Then data(2) = "'" & data(2) End If 'カンマで文字列結合 For j = 0 To UBound(data) If j = 0 Then rec = data(j) Else rec = rec & "," & data(j) End If Next svData(fCnt) = rec 'カンマを付けたデータを格納 Wend Close #Fno 'csvファイルを上書きする Open fPth For Output As #Fno For i = 1 To fCnt Print #Fno, svData(i) Next i Close #Fno End Sub
このコードを実行したCSVファイルを開いた結果が以下の画像です↓↓
シングルクォートが付いて、文字列になっていますね！
メモ帳からCSVファイルを見て見ましょう！
シングルクォートが付いていますね。
以上のように、数値として先頭に00が付いているのは問題になりにくいと思いますが、
シリアル番号はダメですよね(;^ω^)
文字列として扱うべきですよね。この罠に私もはまったので参考になればと思います。
備忘録でした(^^)/~~~
配列のデータを並び替えて配列に格納し直す
配列の並び替えはしんどい
配列のデータも並び替えはできるらしいのですが、しんどい(;^ω^)
なので、いったんWorkSheetに配列データを格納して、並び替えたデータを配列に格納する方法を記述しました。
Public arrMy, arrMy2, rangeMy As Range Sub 配列→Range→配列() 'Sheetのデータを配列に格納 arrMy = Range("A1").CurrentRegion '新規Bookに配列の値を格納 Worksheets.Add.Name = "Temp" Range(Cells(1, 1), Cells(UBound(arrMy), UBound(arrMy, 2))) = arrMy '並び替えたRangeを配列に格納する。 Set rangeMy = Range("A1").CurrentRegion rangeMy.Sort Key1:=Range("B2"), order1:=xlAscending arrMy2 = rangeMy 'Sheetの削除（削除時のメッセージを表示しない） Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True End Sub
現在、プロジェクト単位でモジュールを作成しており、その中で並び替えがことなる場合があります。その場合に対応するためにこんなことをしたかったのです。
備忘録でした。(^^)/~~~
