配列にデータを格納し、数値と文字列でファイル保存する方法| OKWAVE

Excel VBAの文字列と数値の分類

txtファイルで取り込んだ2行にまたがっている数値・英文字・ひらがななどを、数値だけのtxtファイルとそれ以外のtxtファイルを別々に作成し、保存するプログラムを組みたいのですが、よく分かりません。ちなみに、使っているOSとAPはWinXP、Excel2003です。 InputData.txtの内容 A34bFg7p0 あ 1ylut890 B45LK4L え Number.txtの完成形 34701890454 String.txtの完成形 AbFgp あ ylutBLKL え '変数の宣言 Dim myFile As String Dim CC As Integer Dim XX As Integer Dim WW As Variant Dim str As String Dim tempStr As String Dim B As String Dim C As String myFile = Dir("InputData.txt") 'ファイルの読み込み If myFile = "InputData.txt" Then Open myFile For Input As #1 Do While Not EOF(1) Input #1, myText Loop '書き込みファイルの作成 Open "Number.txt" For Output As #2 Open "String.txt" For Output As #3 '数字・文字列の分類 CC = Len(myFile) For XX = 1 To CC str = Mid(myFile, XX, 1) If str >= 0 And str <= 9 Then B = B & str Else C = C & str End If Next Print #2, B Print #3, C Close #1, #2, #3 'エラーメッセージの表示 Else MsgBox "ファイルは存在しません。" End If ここまでやっている状態です。よろしくお願いします。

ラベルに全てのテキストデータを読み込みたい

メモ帳（.txt）にＡＡＡＡＢＢＢＢＣＣＣＣと書いて、これら３行をラベルに表示させたいのです。 Private Sub Form_Load() 　Dim myText As String 　Open "C:\myFile.txt" For Input As #1 Do While Not EOF(1) Input #1, myText Loop 　　Close #1 　Label1.Caption = myText End Sub 上記のコードだと１行目のＡＡＡＡしか表示されません（泣）どなたかご指導宜しくお願いします。

最終行がわからない場合

エクセルです。・最終行は毎回違ってくるので Cells(Rows.Count, "A").End(xlUp).Row で取得したいです。・今は最終行が51行という前提で作業をしています。・1行目にはタイトルが入っています。・2行目以降には文字が入っています。　今回はテストのため数字を入れました。最終行が51の場合は ************************************************ Sub test1() Dim i As Long Dim cnt As Long For i = 1 To 10 Call test2 Next End Sub -------------------- Sub test2() Dim str As String If cnt = 0 Or cnt = 42 Then cnt = 2 ElseIf cnt = 2 Then cnt = cnt + 10 ElseIf cnt = 12 Then cnt = cnt + 10 ElseIf cnt = 22 Then cnt = cnt + 10 ElseIf cnt = 32 Then cnt = cnt + 10 End If With Sheets("Sheet1") For myRow = cnt To cnt + 9 str = str & "," & .Cells(myRow, 1) Next myRow End With Debug.Print str End Sub ************************************************ このような方法で、str に１０個ずつセルの値を格納できるのですが最終行が不明の場合はどうすればいいのでしょうか？イミディエイトウインドウに表示される値は ,1,2,3,4,5,6,7,8,9,10 ,11,12,13,14,15,16,17,18,19,20 ,21,22,23,24,25,26,27,28,29,30 ,31,32,33,34,35,36,37,38,39,40 ,41,42,43,44,45,46,47,48,49,50 ,1,2,3,4,5,6,7,8,9,10 ,11,12,13,14,15,16,17,18,19,20 ,21,22,23,24,25,26,27,28,29,30 ,31,32,33,34,35,36,37,38,39,40 ,41,42,43,44,45,46,47,48,49,50 です。最終行まで来たらまた2行目から取得しなおします。なのでIf cnt = 0 Or cnt = 42 Thenにしました。最終行が60だったり65だったりした場合は、strに10個格納できないですが、少ない分には問題ないです。これで、最終行が100でも200でも対応できるコードを作りたいのですがわかりません。お知恵を拝借願います。

Excel VBA 文字列を配列にて格納

初心者なので、申し訳ございません。使用しているOS WinXP、アプリケーション Excel2003 保存してあるtxtファイルに入っている文字列を、重複するデータをグループ化して、最終的に別のtxtファイルにて出力するのですが、最初の配列して格納するところから分かりません。参考までに・・・入力ファイル「InputData.txt」相川関本川上関本久保相川川上久保青木出力ファイル「Group.txt」相川関本川上久保青木今のところは、ここまでやっています。 Dim A As String Dim myText2 As String A = Dir("InputDate.txt") If A = "InputDate.txt" Then Open A For Input As #1 Do While Not EOF(1) Input #1, myText2 myText = myText & myText2 Loop Open "Group.txt" For Output As #2 よろしくお願いします。

VB2005で、Structureの配列を返すプログラムを以下のように書きたい

VB2005で、Structureの配列を返すプログラムを以下のように書きたいのですが、そもそもVB6しか使ったことが無いもので、以下のような素数の結果を返すこのプログラムの書き方はVB2005らしいでしょうか？ Module Module1 Public Structure SosuuStatus Public num As Integer Public status As String End Structure Class Sosuu Function SosuuCheck(ByVal st As Integer, ByVal ed As Integer) As SosuuStatus() Dim i As Integer, j As Integer Dim sosuu(0 To ed - st) As SosuuStatus Dim cnt As Integer = 0 For i = st To ed sosuu(cnt).num = i sosuu(cnt).status = "" '初期化 If 1 = i Then sosuu(cnt).status = "素数ではない" ElseIf 0 = (i Mod 2) Then sosuu(cnt).status = "素数ではない" Else For j = 3 To Math.Sqrt(ed) If 0 = (i / j) Then sosuu(cnt).status = "素数ではない" End If Next j End If If sosuu(cnt).status = "" Then sosuu(cnt).status = "素数である" End If cnt = cnt + 1 Next i SosuuCheck = sosuu End Function End Class End Module

配列のセットの仕方

度々質問してすいません。英文の単語を抽出して頻度順に並べるプログラムをＶＢで作りたいと思っております。下記ＵＲＬのＶＢ版です。（http://gamp.c.u-tokyo.ac.jp/archive/perl.htm）以下が作成したソースです。これとQuickSortのソース（http://www.geocities.co.jp/SilkRoad/4511/vb/sort.htm）を繋げて終わりたいと思うのですが、どうつなげたらいいのかわかりません。アドバイスをお願いいたします。 Private Sub Command1_Click() Dim strTarget As String Dim strResult As String Dim cha As String Dim chaList() As String Dim word As String Dim wordList() As Long Dim i As Long, j As Long Dim EndFlg As String strTarget = Me.Text1.Text i = 0 EndFlg = "" Do Until EndFlg = "END" i = i + 1 cha = Mid(strTarget, i, 1) If cha <> "" Then ReDim Preserve chaList(i) chaList(i - 1) = cha Else EndFlg = "END" End If Loop For i = 0 To UBound(chaList) - 1 If chaList(i) = "." Then chaList(i) = " " End If Next Text2 = "" For i = 0 To UBound(chaList) - 1 Text2 = Text2 & chaList(i) Next Text3 = "" word = "" For i = 0 To UBound(chaList) - 1 If chaList(i) = " " Then If i = 0 Then Else If chaList(i - 1) = " " Then Else Text3 = Text3 & Chr(13) & Chr(10) & word word = "" End If End If Else word = word & chaList(i) End If Next If word <> "" Then Text3 = Text3 & Chr(13) & Chr(10) & word End If

配列内の要素が空だった場合、空要素を削除したい。

お世話になります。どなたかお助けください。 B7:B11のセルの値で、空ではないものをGlNaviA()に格納していき、GlNaviAのUboundを動的に変更しております。ここで格納された空以外の要素をSub GlNaviに渡しているのですが、正しく値が渡せていないみたいで、エラーになってしまいます…。どこかおかしいとこはあるでしょうか。プログラムは初心者レベルです…。 Option Explicit Private GlNaviA() As Variant Public cnt As Integer Public Sub ABC() 省略… cnt = 0 For i = 0 To 4 If SH2.Range("B" & i + 7).Value <> "" Then ReDim Preserve GlNaviA(cnt) GlNaviA(cnt) = SH2.Range("B" & i + 7).Value cnt = cnt + 1 End If Next i 　　MsgBox GlNaviA(cnt) 省略… End Sub Public Sub GlNavi(ByVal f As TextFile) If UBound(GlNaviA) = 4 Then f.TextWriteLine GlNaviA(0) f.TextWriteLine GlNaviA(1) f.TextWriteLine GlNaviA(2) f.TextWriteLine GlNaviA(3) f.TextWriteLine GlNaviA(4) ElseIf UBound(GlNaviA) = 3 Then f.TextWriteLine GlNaviA(0) f.TextWriteLine GlNaviA(1) f.TextWriteLine GlNaviA(2) f.TextWriteLine GlNaviA(3) ElseIf UBound(GlNaviA) = 2 Then f.TextWriteLine GlNaviA(0) f.TextWriteLine GlNaviA(1) f.TextWriteLine GlNaviA(2) ElseIf UBound(GlNaviA) = 1 Then f.TextWriteLine GlNaviA(0) f.TextWriteLine GlNaviA(1) Else f.TextWriteLine GlNaviA(0) End If End Sub

指定した範囲で0の行を削除するマクロ

以下のコードで7列目が0の行を削除するマクロを作ったのですが、 13行目以降を削除するように指定できますでしょうか？ 1-12行は別のシートに数式を入れているため、削除したくないのですが、うまくいきません。よろしくお願いいたします。 Sub 行削除() Dim Rw As Long Dim Cnt As Long Application.ScreenUpdating = False For Rw = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1 With Cells(Rw, 7) If .Value = 0 Then .EntireRow.Delete Cnt = Cnt + 1 End If End With Next If Cnt = 0 Then MsgBox "削除対象行は、見つかりません。", vbExclamation Else MsgBox Cnt & " 件見つかり行を削除しました。", vbInformation End If End Sub

符号付きの係数の出力（散布図近似式）

QNo.4257168 にて質問したものです。図の中で表現されている５次の式の係数（６個あります）をセルの中に書き出すマクロに関して下記のコードを教えて頂いたのですが、係数は数字のみ出力され、－の符号は出力されません。どのようにしたら符号付きの係数の出力が可能になるでしょうか。（大変簡潔なコードで感心しています） Sub test() 　　Dim str As String 　　Dim strv As Variant 　　Dim i As Integer 　　str = "y = 0.0452x5 - 8.6275x4 + 658.58x3 - 25133x2 + 4795.20x - 4E+0.6" 　　strv = Split(str, " ") 　　For i = 0 To UBound(strv) 　　　　If strv(i) Like "*E+*" Then 　　　　　　MsgBox strv(i) 　　　　Else 　　　　　　If Val(strv(i)) > 0 Then 　　　　　　　　MsgBox Val(strv(i)) 　　　　　　End If 　　　　End If 　　Next i

Like演算子で、[と]を文字として扱い比較したい

今、フォルダ内のファイルリストを作成するVBA(Excel2003)を作っています。そこで、ファイル（絶対パス：フルパス）に「含まれていい文字」と「含まれない文字」（キーワード）を指定できる機能を作っています。以前、VB6で類似の機能を作った時は、すんなり行ったのですが、VBAではうまくいきません。正規表現が使えるに越したことはないのですが、「 [ や ] を文字として認識するだけでもいいです。」リストを作るフォルダには、　[20].txt 　テキスト[a]txt 　メモ[10] - コピー.txt などのテストファイルとその他ファイルが存在します。キーワードを指定しないときには、うまく行きます。指定すると、たとえば [10].txt というファイルがヒットしないように、NGワードを [10] を指定すると、[20].txtまでヒットしません。[a]では全てがヒットしません。また、OKワードに[10]を指定すると[10]と[20]がヒットします。 ===== NGワードを比較している部分 ==== 引数：in_str が NGワード（スペースで区切って複数指定可能）引数：target_Str がフルパス Public Function keywords_NG(in_Str As String, target_Str As String) As Boolean 　　If in_Str = "" Then 　　　　keywords_NG = True 　　　　Exit Function 　　End If 　　　　Dim wordArray() As String 　　Erase wordArray() 　　wordArray() = Split(in_Str, Space(1)) 　　　Dim tempFLG As Boolean 　　tempFLG = True 　　　　Dim wordIDX As Long 　　For wordIDX = 0 To UBound(wordArray) Step 1 　　　　If wordArray(wordIDX) <> "" And target_Str <> "" Then 　　　　　　If target_Str Like "*" & wordArray(wordIDX) & "*" = True Then 　　　　　　　　tempFLG = False 　　　　　　End If 　　　　End If 　　Next 　　If tempFLG = True Then 　　　　keywords_NG = True 　　Else 　　　　keywords_NG = False 　　End If End Function ===== OKワードを比較している部分 ==== 引数：in_Str が OKワード（スペースで区切って複数指定可能）引数：target_Str がフルパス Public Function keywords_OK(in_Str As String, target_Str As String) As Boolean 　　If in_Str = "" Then 　　　　keywords_OK = True 　　　　Exit Function 　　End If 　　Dim wordArray() As String 　　Erase wordArray() 　　wordArray() = Split(in_Str, Space(1)) 　　　　Dim tempFLG As Boolean 　　tempFLG = False 　　　　Dim wordIDX As Long 　　For wordIDX = 0 To UBound(wordArray) Step 1 　　　　If wordArray(wordIDX) <> "" And target_Str <> "" Then 　　　　　　If target_Str Like "*" & wordArray(wordIDX) & "*" = True Then 　　　　　　　　tempFLG = True 　　　　　　End If 　　　　End If 　　Next 　　　　If tempFLG = True Then 　　　　keywords_OK = True 　　Else 　　　　keywords_OK = False 　　End If 　　 End Function ===== [や]を区切り文字ではなくする関数 ==== Public Function keywords_escape_sequence(keywordStr As String) As String 　　　　If keywordStr = "" Then 　　　　keywords_escape_sequence = "" 　　　　Exit Function 　　End If 　　　　Dim myIDX As Currency 　　Dim str_X As String 　　　　str_X = "" 　　　　　　For myIDX = 1 To Len(keywordStr) Step 1 　　　　If Mid(keywordStr, myIDX, 1) = "[" Then 　　　　　　str_X = str_X & "[[]" 　　　　ElseIf Mid(keywordStr, myIDX, 1) = "]" Then 　　　　　　str_X = str_X & "[]]" 　　　　Else 　　　　　　str_X = str_X & Mid(keywordStr, myIDX, 1) 　　　　End If 　　Next 　　　　keywords_escape_sequence = str_X End Function ===================================================== 　　　　If keywords_OK(keywords_OK_Str, フルパス)) = True And _ 　　　　　　keywords_NG(keywords_NG_Str, フルパス)) = True Then 　　　　　　　　'ファイルリスト作成　　　　end if ===================================================== 正規表現を使うためには…というページを見つけ参照設定に以下の項目にチェックを入れてみましたが、結果は変わらす □Microsoft VBScript Regular Expressions 5.5 ===== RegExp と CreateObject ==== 参照設定をできれば変更したくない場合は、RegExp と CreateObject を使えば良いとあるページに書いてありましたが、参照設定でもできなかったので、これだけは試してません。ヒントだけでもお教えください。

サンプルプログラムでエラーが出てしまいます、対処法を教えて下さい。

Sub test写真の連続挿入() 　　Dim myDir As String 　　Dim myFile As String 　　Dim i As Integer 　　Dim n As Integer 　　n = 10 　　myDir = "D:\写真\" myFile = Dir(myDir, vbNormal) 　　Application.ScreenUpdating = False 　　Do Until myFile = "" 　　If myFile <> "." And myFile <> ".." Then 　　If (GetAttr(myDir & myFile) And 16) <> 16 Then 　　i = i + 1 　　With ActiveSheet.OLEObjects("Image" & i) 　　　.Object.PictureSizeMode = 3 　　　.Object.Picture = LoadPicture(myDir &myFile) 　　End With 　　If i = n Then Exit Do 　　End If 　　End If 　　myFile = Dir 　　Loop 　　Application.ScreenUpdating = True End Sub このWith ActiveSheet.OLEObjects("Image" & i)の行でエラーが出てしまいます、対処法を教えて下さい。（実行時エラー'1004'OLEObjects プロパティを取得できません）

データを一覧で表示する方法

VB6.0ProfessionalEditionで、 Accessのデータを一覧表示するのを作っているんですが、どうも上手くいかないんです。 OLE_ListというExcelのシートに表示させたいんでFormLoad時に書いていってるんですが、どこがマズおんでしょう？ Dim OLE_List(5, 10) As String Dim rs_cnt As Integer Dim i As Integer （DAOでコネクトして、変数rsでレコードセットしてます） rs_cnt = rs.RecordCount If rs_cnt > 0 Then i = 0 For i = 0 To rs_cnt - 1 str_co = rs("通販会社") str_name = rs("商品名") str_price = rs("価格") str_orderday = rs("注文日") str_slip = rs("伝票No.") OLE_List(1, i) = str_co OLE_List(2, i) = str_name OLE_List(3, i) = str_price OLE_List(4, i) = str_orderday OLE_List(5, i) = str_slip Next End If

ユーザー定義関数の再計算

ユーザー定義関数を作りました。ところが、この関数が自動再計算をしてくれません。どうしたら自動再計算するようになるのでしょうか？よろしくお願いします。ちなにこの関数は、自分のシートのB2とsheet1～sheet4のB9を比較して、正しければB9の４つ右のセルの値を合計して返すものです。 =SheetLook($B$2,"sheet1,sheet2,sheet3,sheet4",B9,4) コードです。 Function SheetLook(参照元 As Variant, 比較対象シート As String, 比較対象セル As Range, 参照セル位置 As Integer) As Variant 　　Dim i As Integer 　　Dim rng As Range 　　Dim sss As Variant 　　Dim kei As Variant 　　Dim cnt As Integer 　　sss = Split(比較対象シート, ",") 　　kei = 0 　　cnt = 0 　　For i = 0 To UBound(sss) 　　　　Set rng = Sheets(sss(i)).Range(比較対象セル.Address) 　　　　If 参照元 = rng Then 　　　　　　kei = kei + rng.Offset(0, 参照セル位置) 　　　　　　cnt = cnt + 1 　　　　End If 　　Next 　　If cnt <> 0 Then 　　　　SheetLook = kei 　　Else 　　　　SheetLook = "" 　　End If End Function

Excelで同一セル内に入力されているデータを他のセルに分割したい

http://okwave.jp/qa4369634.html?ans_count_asc=20 で質問をして、何度かやりとりをさせていただいてエクセルで同一セル内に、セル内改行で１～６列ほどのデータが入力されています。縦にデータが入力されていて、それぞれのセルにセル内改行を含み、データが入力されています。それぞれのセル内のデータを… 例えば、A1セル内に５行入力されていたら、A2セルから入力されている行数分（ここでいうと5行）挿入し、それぞれにデータを分割して入力させたい。かつ、B・Cセルは増えたセルにそれぞれのデータをコピーしたいと言ったら、 Sub Macro1() Dim idx, cnt As Integer Dim wkStr() As String Dim rng As Range 　　ActiveSheet.Copy after:=ActiveSheet 　　For idx = Range("A65536").End(xlUp).Row To 1 Step -1 　　　　If InStr(Cells(idx, "A"), Chr(10)) > 0 Then 　　　　　　wkStr = Split(Cells(idx, "A").Value, Chr(10)) 　　　　　　Set rng = Cells(idx, "B") 　　　　　　For cnt = UBound(wkStr) To 0 Step -1 　　　　　　　　Cells(idx, "A").Value = wkStr(cnt) 　　　　　　　　Cells(idx, "B").Value = rng.Value 　　　　　　　　Cells(idx, "C").Value = rng.Offset(0, 1).Value 　　　　　　　　If cnt > 0 Then 　　　　　　　　　　Cells(idx, "A").Resize(1, 3).Insert shift:=xlDown 　　　　　　　　End If 　　　　　　Next cnt 　　　　End If 　　Next idx End Sub といったマクロのご回答をいただきました。これを元に、・データが入っているセルをA列→B列に変更・A列のデータはセルが増えた分だけ増やしたい・A1に対応するデータがC1・D1に入っていた場合、対応するデータは残したまま、B列が増えただけ、列を増やしたいと変更したいのですが…。すいませんが、宜しくお願い致します。

テキストファイルの中からURLを抽出するには？

ＶＢＡで読み込んだテキストファイルからＵＲＬ部分だけを抽出するにはどうしたらよいでしょうか？ InStr関数とMid関数を使って、先頭：http～終わり：空白 or Chr(13)をURLとして切り取っているのですがうまく行きません。どうも終わり部分の判定が甘いようです。 Sub GetURL(myText) 　　　　'テキストからURLを抽出　Dim myText As String 　Dim myURL As String　　　'URL取り込み用　Dim str_pt As Long　　　　　'文字列用ポインタ　str_pt = 1　　　　　　　　　　'最初は1文字目から　Do While 1 　　str_pt = InStr(str_pt, myText, "http") 　　If str_pt = 0 Then Exit Do 　　Do While 1 　　　letter = Mid(myText, str_pt, 1) 　　　If letter = Chr(20) Or letter = Chr(13) Then Exit Do 　　　myURL = myURL & letter 　　　str_pt = str_pt + 1 　　Loop 　　Debug.Print myURL 　　myURL = "" 　Loop End Sub アドバイスをお願いします！

複数の.csvファイルから指定数値を取り出す

毎度御世話になります。あるフォルダ内の複数の.csvファイル一つ一つから指定数値(B列6行目のみ)を取り出して、デスクトップ上、別のExcelシートの(B列１行毎に日付と時間が書いてある) 隣のC列にまとめて自動で書いてくれるプログラムを考えます。使用するファイル名は HU20150513_110000_AI2.csv　です。コードの該当行'ファイル名を配列変数に格納　のところを、上記ファイル名にしても、「型が一致しません」とエラーが出るのですが、どこか他に変更点があるのでしょうか。詳しい方、宜しく御願い申し上げます。 ■VBAコード Sub 値取得() '配列変数を宣言 Dim filnames As Variant Dim myfile As Variant Dim cnt As Long Dim mybook As Workbook Dim outbook As Worksheet Dim fname As String Dim mySerial As Date Dim myRng As Variant Dim key As String '出力先の先頭行番号 cnt = 1 '出力先のブックを格納 Set outbook = ActiveWorkbook.ActiveSheet 'ファイル名を配列変数に格納 filnames = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", MultiSelect:=True) 'キャンセル時の処理 If IsArray(filnames) = False Then Exit Sub 'ファイルの数だけ繰り返し Application.ScreenUpdating = False For Each myfile In filnames 　　'ファイル開く　　Set mybook = Workbooks.Open(Filename:=myfile, ReadOnly:=True) 　　'ファイル名からシリアル値の作成　　fname = Format(Left(mybook.Name, 12), "0000/00/00 00:00") 　　mySerial = DateValue(fname) + TimeValue(fname) 　　'値を取得・出力先へ書き出し　　mybook.Activate 　　key = Year(mySerial) & Month(mySerial) & Day(mySerial) & Hour(mySerial) 　　For Each myRng In outbook.Columns("B").SpecialCells(xlCellTypeConstants, 23) 　　　　If IsDate(myRng) Then 　　　　　　If Year(myRng) & Month(myRng) & Day(myRng) & Hour(myRng) = key Then 　　　　　　　　myRng.Offset(0, 1).Value = ActiveSheet.Range("B6").Value 　　　　　　　　Exit For 　　　　　　End If 　　　　End If 　　Next myRng 　　'ファイル閉じる　　Application.DisplayAlerts = False 　　Workbooks(mybook.Name).Close 　　Application.DisplayAlerts = True 　　'カウントアップ　　cnt = cnt + 1 Next myfile Application.ScreenUpdating = True End Sub

2010 ｅｘｃｅｌ　マクロ　記号の変化

エラー発生で強制終了になってしまいます。2007年のｅｘｃｅｌで作成したものですが、2010だと強制終了になってしまいます。内容は□をダブルクリックすると■になるように作っています。記述は2003年からのマクロ記述なので、変化が必要なのでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'セルをダブルクリックすると、・→○→△→×→・と変更する。 Dim S1 As String Dim S2 As String Dim S01 As String Dim S02 As String Dim S03 As String Dim S04 As String S1 = "□" S2 = "■" S01 = "・" S02 = "○" S03 = "△" S04 = "×" On Error GoTo ERR_12 sCheckXY S1, S2 sCheckX1234 S01, S02, S03, S04 sChangeXY S1, S2 Exit Sub ERR_12: End End Sub Sub sChangeXY(X As String, Y As String) '選択セルに□があれば■に変える Dim Str0 As String 'str1の左端 Dim Str1 As String 'strの右側更新 Dim Str2 As String 'strの左側更新 Dim Str20 As String 'strの左側一部保存 Dim L As Long Dim M As Long Dim N As Long Str1 = ActiveCell.Text L = Len(Str1) Debug.Print L If L = 0 Then End End If For N = 1 To L Debug.Print Str2 Str0 = Left(Str1, 1) If Str0 = X Or N = L Then If Str20 <> "" Then If N = L Then Str20 = Str20 + Str0 End If If MsgBox(Str20 & "　　はチェックしますか？", vbYesNo, "選択肢") = vbYes Then Str2 = Str2 + Replace(Str20, X, Y) Str20 = Str0 Else Str2 = Str2 + Replace(Str20, Y, X) Str20 = Str0 End If Else Str20 = Str0 End If Else Str20 = Str20 + Str0 End If Str1 = Right(Str1, L - N) Next N ActiveCell.Value = Str2 End Sub Sub sCheckXY(X As String, Y As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X Then ActiveCell.Value = Y End ElseIf ActiveCell.Text = Y Then ActiveCell.Value = X End End If End Sub Sub sCheckX1234(X1 As String, X2 As String, X3 As String, X4 As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X1 Then ActiveCell.Value = X2 End ElseIf ActiveCell.Text = X2 Then ActiveCell.Value = X3 End ElseIf ActiveCell.Text = X3 Then ActiveCell.Value = X4 End ElseIf ActiveCell.Text = X4 Then ActiveCell.Value = X1 End End If End Sub

配列のフリーズを解消してください。

Sub データ原本() Dim wsAll As Worksheet Set wsAll = Worksheets("All(5)") Dim lRow As Long, lCol As Long Dim i As Long, j As Long, cnt As Long With Worksheets("データ原本") '日付S行を日付に変更(「.」を「/」に置換) lRow = .Cells(Rows.Count, 1).End(xlUp).Row Dim MyArray As Variant MyArray = Range(.Cells(10, 1), .Cells(lRow, 1)) For i = 1 To lRow - 9 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/") Next Range(.Cells(10, 1), .Cells(lRow, 1)) = MyArray Erase MyArray '配列の初期化 '「天気」両サイドの &「内・外」両サイドの空白スペースを削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row MyArray = Range(.Cells(10, TNK), .Cells(lRow, TNK)) For i = 1 To lRow - 9 MyArray(i, 1) = Trim(MyArray(i, 1)) Next Range(.Cells(10, TNK), .Cells(lRow, TNK)) = MyArray Erase MyArray '配列の初期化 '数値0のデータ行の行削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(9, Columns.Count).End(xlToLeft).Column Dim arr_A As Variant, arr_B As Variant arr_A = Range(.Cells(9, 1), .Cells(lRow, lCol)).Value ReDim arr_B(1 To lRow - 8, 1 To lCol) cnt = 0 For i = 1 To lRow - 8 If arr_A(i, 18) <> 0 Then cnt = cnt + 1 For j = 1 To lCol arr_B(cnt, j) = arr_A(i, j) Next j End If Next i .Range("A9").Resize(lRow, lCol).Value = arr_B End With End Sub 　上記のコードを2回実行すると2回目には、 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/")のところで「型が一致しません。」とフリーズします。かと言って「 '数値0のデータ行の行削除」コードを一括削除して、実行ボタンを何度押してもフリーズすることはありません。どこに不具合が生じているのかわからないのですが、どなたか名回答を宜しくお願いします。

配列に格納したデータを指定行以下に転記する方法

excel2000を使っています。以下のコードだと最終行にデータが転記されます。これを４行目に確定して、転記したいのです。常に４行目つまりＡ列４行目以下に上書きしたいのです。その場合コードをどのように変更すべきでしょうか？ Sub 配列() With ActiveSheet ' 配列に格納 --------------------------- Dim i As Integer Dim LastRow As Long Dim SaleAry As Variant ' 配列に格納 --------------------------- SaleAry = Array(.Range("t4"), .Range("e5"), .Range("ｇ5"), .Range("o5")) End With ' 転記 --------------------------- With Worksheets("daityou") LastRow = .Range("A65536").End(xlUp).Row For i = 0 To UBound(SaleAry) .Cells(LastRow + 1, i + 1).Value = SaleAry(i) ' Next i End With Set SaleAry = Nothing End Sub

VBAで任意のフォルダ内のファイルの特定の文字列を

お世話になります。今、Excelを使用しVBAで任意のフォルダ内に含まれるファイル（txt形式ですが拡張子はありません）から、特定のA～Bの部分の文字列のみを抜き出し、ExcelのSheetに出力させるというVBAを作成しようと考えています。また、A～Bで抽出した文字列内に”空白”が含まれる場合、その空白でセルを隔てるという処理を加えたいです。また、それらとは別に任意のフォルダ内に含まれるファイルのファイル名のみを抽出し、Excelに出力するというVBAも作ろうと考えています。私自身、これまでExcelでは関数を使うのが精一杯でVBAの勉強すらしてきませんでしたので、だいぶ困窮しております。どなたか、VBAについて詳しい方、ご教授いただけたら幸いです。以下は、参考までに、特定のフォルダ内に含まれるファイルをSheetに出力するVBAになります。ここからさらに、任意の文字列を検索し、抽出し、出力する機能と、また空白部分でセルを分ける機能、またファイル名一覧を抽出する機能を加えていきたい所存です。どなたか、お力添えの程何卒よろしくお願い致します。 Sub GetAllFile() Dim buf As String, tmp As Variant, cnt As Long, i As Long Dim myFol As String, myFile As String Dim fNo As Integer, myCol As Long With Application.FileDialog(msoFileDialogFolderPicker) .Title = "*** 対象フォルダを選択し、[OK]をクリック ***" .InitialFileName = "C:\" If .Show = True Then myFol = .SelectedItems(1) End If End With myFile = Dir(myFol & "\*") myCol = 0 Do While myFile <> "" fNo = FreeFile Open myFol & "\" & myFile For Input As #fNo Do Until EOF(fNo) Line Input #fNo, buf tmp = Split(buf, ",") cnt = cnt + 1 For i = 1 To UBound(tmp) + 1 Cells(cnt, i + myCol) = tmp(i - 1) Next i Loop Close #fNo myFile = Dir() myCol = myCol + 4 cnt = 0 Loop End Sub 上記、VBAは動作はしましたが、やはりフォルダ内のファイル数の数により、途中でフリーズしてしまう事もありました。ご教授の程、何卒よろしくお願い致します。

配列にデータを格納し、数値と文字列でファイル保存する方法

配列にて格納したデータの出力

質問者が選んだベストアンサー

お礼 2009/03/10 13:27

関連するQ&A

Excel VBAの文字列と数値の分類

ラベルに全てのテキストデータを読み込みたい

最終行がわからない場合

Excel VBA 文字列を配列にて格納

VB2005で、Structureの配列を返すプログラムを以下のように書きたい

配列のセットの仕方

配列内の要素が空だった場合、空要素を削除したい。

指定した範囲で0の行を削除するマクロ

符号付きの係数の出力（散布図近似式）

Like演算子で、[と]を文字として扱い比較したい

サンプルプログラムでエラーが出てしまいます、対処法を教えて下さい。

データを一覧で表示する方法

ユーザー定義関数の再計算

Excelで同一セル内に入力されているデータを他のセルに分割したい

テキストファイルの中からURLを抽出するには？

複数の.csvファイルから指定数値を取り出す

2010 ｅｘｃｅｌ　マクロ　記号の変化

配列のフリーズを解消してください。

配列に格納したデータを指定行以下に転記する方法

VBAで任意のフォルダ内のファイルの特定の文字列を

注目のQ&A

カテゴリ

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

専門家に質問してみよう

配列にデータを格納し、数値と文字列でファイル保存する方法

配列にて格納したデータの出力

質問者が選んだベストアンサー

お礼 2009/03/10 13:27

関連するQ&A

Excel VBAの文字列と数値の分類

ラベルに全てのテキストデータを読み込みたい

最終行がわからない場合

Excel VBA 文字列を配列にて格納

VB2005で、Structureの配列を返すプログラムを以下のように書きたい

配列のセットの仕方

配列内の要素が空だった場合、空要素を削除したい。

指定した範囲で0の行を削除するマクロ

符号付きの係数の出力（散布図近似式）

Like演算子で、[と]を文字として扱い比較したい

サンプルプログラムでエラーが出てしまいます、対処法を教えて下さい。

データを一覧で表示する方法

ユーザー定義関数の再計算

Excelで同一セル内に入力されているデータを他のセルに分割したい

テキストファイルの中からURLを抽出するには？

複数の.csvファイルから指定数値を取り出す

2010 ｅｘｃｅｌ マクロ 記号の変化

配列のフリーズを解消してください。

配列に格納したデータを指定行以下に転記する方法

VBAで任意のフォルダ内のファイルの特定の文字列を

注目のQ&A

カテゴリ

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

専門家に質問してみよう

2010 ｅｘｃｅｌ　マクロ　記号の変化