- 締切済み
VBA 桁数が混在するソート
Picosoftの回答
- Picosoft
- ベストアンサー率70% (274/391)
> argAryはジャグ配列なのですが > 一部文字列が含まれている列があるので型が合わないと怒られてしまいました > VarTypeで見たところご推測の通り数値だけの列も文字列の8と返って来ましたが > 列が文字列かどうかを固定で処理するのも好ましくないので > とりあえず、最初にIsNumericを利用して数値のみの列であれば別の配列に渡して > 間接的な処理をしようかと思うのですが他によさそうな手法があればご教授下さい。 ふむ、数値以外のデータも含まれるということですね……。 どういうデータがあるのかはわかりませんが、 以下のような出力を望んでいるのでしょうか？ "1", "01", "2", "15", "1a", "abc", "11a" (入っているデータはこんな感じですか？) ↓ソート "01", "1", "1a", "2", "11a", "15", "abc" (辞書順にソートすると"01", "1", "11a", "15", "1a", "2", "abc"となる) もしそうであるなら、 2つの文字列を比較して大小を判断するための自作メソッド(VB.NETでいうCompareToメソッド)を作るといいかもしれません。 例： Function CompareStrings(ByVal str1 As String, ByVal str2 As String) As Integer str1とstr2を比較し、以下の数を返す ・str1 < str2としたいなら負の数 (str1="1a", str2="11a"なら負の数) ・str1 = str2なら0 ・str1 > str2としたいなら正の数 (str1="11a", str2="1a"なら正の数) このようなメソッドを作っておけば、QuickSort1メソッドの修正は Do While argAry(sortnum)(i) < vBase Do While argAry(sortnum)(j) > vBase をそれぞれ Do While CompareStrings(argAry(sortnum)(i), vBase) < 0 Do While CompareStrings(argAry(sortnum)(j), vBase) > 0 と書き換えるだけで済みます。
関連するQ&A
- 配列のセットの仕方
度々質問してすいません。 英文の単語を抽出して頻度順に並べるプログラムをＶＢで作りたいと思っております。下記ＵＲＬのＶＢ版です。 （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
- ベストアンサー
- Visual Basic
- 素数を求めるマクロを
走らすと暴走したようになり、素数＝１５１で止まります。 どこが悪いのでしょうか。正常に終わるようにしたいです。 ====================== Sub 素数を求める() Dim i As Long Dim j As Long Dim m As Long Dim p As Long Dim flg As Boolean i = 1 j = 1 p = 2 Do flg = False For m = 2 To Int(Sqr(p)) If p Mod m = 0 Then flg = True Exit For End If Next If flg = False Then Cells(i, j) = p i = i + 1 If i > Rows.Count Then i = 1 j = j + 1 End If End If p = p + 1 Loop End Sub ======================
- 締切済み
- Excel（エクセル）
- (VBA) 部分集合和問題
TVを録画した複数の動画ファイルがあります。 これをBDにムーブする場合 BDの容量25GBになるべく上手く収まるようにファイル組み合わせたいと思います。 （一つのファイルで25GB以上になる事はありません。） つまり、 複数のファイルを組み合わせて25GBを超えないで 最大25GBに一番近いように組み合わせる手法です。 ファイルが複数あるので 2枚以上になる場合は、1枚を決定後に 残ったファイルから同じ手法で25GBに上手く収まるようにファイルを選択します。 数学的には「部分集合和問題」と言うそうです。 現在、複数の動画ファイルは、2行目から 各ファイルのファイル名（b列）とサイズ（ｃ列）をセルに記載済みです。 （1行目は見出し行） ---------------------------------- 参考になる記事をネットで探してみました。 下記などが参考になりそうです。 http://kikutips.blog13.fc2.com/blog-entry-201.html 初心者の私が理解できたのは、 C列にデータ、D列に目標値（25GB＝25600MB）を記入してEnterをクリックすると 新規シートに組み合わせの結果が表示されると言う事です。 参考画像（結果表示） https://imgur.com/Fmav5hZ ------------------------------------- 上記から入手出来るサンプル（kent201.zip)は、 組み合わせが目標値と同じ値になる場合しか結果が表示されません。 これを目標値を超えないで一番近い数値をのみを求めるように改造したいのです。 （もちろん、目標値と同じ組み合わせがあれば最上位の候補になります。） 以下に、kent201.zipのコードを添付しました。 Option Explicit Dim dic As Object Public Sub Samp2(dicR As Object, vS As Variant) Dim vSrc As Variant Set dic = CreateObject("Scripting.Dictionary") vSrc = mySort(dicR.Items) Call NotReCode(vS, vSrc) Call myPrint2(vS, vSrc, dic.Items) Set dic = Nothing End Sub Private Function mySort(ByVal vSrc As Variant) As Variant Dim v As Variant Dim i As Long Dim bNG As Boolean bNG = True While (bNG) bNG = False For i = LBound(vSrc) To UBound(vSrc) - 1 If (vSrc(i)(0) < vSrc(i + 1)(0)) Then v = vSrc(i) vSrc(i) = vSrc(i + 1) vSrc(i + 1) = v bNG = True End If Next Wend For i = UBound(vSrc) - 1 To LBound(vSrc) Step -1 vSrc(i)(2) = vSrc(i + 1)(0) + vSrc(i + 1)(2) Next mySort = vSrc End Function Private Sub NotReCode(vNum As Variant, vSrc As Variant) Dim iPosAry() As Long, iPosMax As Long Dim iRdPos As Long, iPos As Long Dim vSum As Variant, v As Variant Dim i As Long iPosMax = UBound(vSrc) iRdPos = LBound(vSrc) iPos = iRdPos ReDim iPosAry(iPos To iPosMax) vSum = 0 While (vSrc(iRdPos)(0) > vNum) iRdPos = iRdPos + 1 If (iRdPos > iPosMax) Then Exit Sub Wend While (1) v = vNum - vSum Do If (iRdPos > iPosMax) Then If (iPos <= LBound(iPosAry)) Then Exit Sub ' ここでのみ大元 While を抜ける iPos = iPos - 1 iRdPos = iPosAry(iPos) + 1 vSum = vSum - vSrc(iRdPos - 1)(0) v = vNum - vSum End If Do While (iRdPos <= iPosMax) If ((vSrc(iRdPos)(0) + vSrc(iRdPos)(2)) < v) Then iRdPos = iPosMax ElseIf (vSrc(iRdPos)(0) <= v) Then Exit Do End If iRdPos = iRdPos + 1 Loop Loop While (iRdPos > iPosMax) iPosAry(iPos) = iRdPos If (v = vSrc(iRdPos)(0)) Then i = dic.Count dic(i) = Array(iPosAry, iPos) Else vSum = vSum + vSrc(iRdPos)(0) iPos = iPos + 1 End If iRdPos = iRdPos + 1 Wend End Sub Private Sub myPrint2(vNum As Variant, vSrc As Variant, vA As Variant) Dim iRowMax As Long Dim i As Long, j As Long Dim v As Variant, vv As Variant Dim vData As Variant On Error Resume Next iRowMax = UBound(vA) - LBound(vA) + 2 If (iRowMax > Rows.Count) Then iRowMax = Rows.Count ReDim vData(1 To iRowMax, 1 To UBound(vSrc) - LBound(vSrc) + 2) vData(1, 1) = vNum i = 2 For Each v In vSrc vData(1, i) = v(0) i = i + 1 Next j = 1 For Each v In vA vv = v(0) vData(j + 1, 1) = j For i = LBound(vv) To v(1) vData(j + 1, vv(i) - LBound(vSrc) + 2) = "○" Next j = j + 1 If (j > iRowMax) Then Exit For Next Application.ScreenUpdating = False With Worksheets.Add(After:=ActiveSheet) With .Cells(1, 1).Resize(iRowMax, UBound(vData, 2)) .Value = vData .Rows(1).Interior.
- ベストアンサー
- Excel（エクセル）
- 実行するとどうなるのでしょうか？
Private Sub CommandButton1_Click() Dim a, rng As Range, n As Long On Error GoTo Last Set rng = Application.InputBox("A1:I29", Type:=8) If Not rng Is Nothing Then Exit Sub On Error GoTo 0 a = rng.Value ReDim Preserve a(1 To rng.Rows.Count, 1 To rng.Columns.Count + 1) For i = 2 To UBound(a, 1) If IsEmpty(a(i, 2)) Then n = 0 Do While IsEmpty(a(i + n, 2)) a(i + n, UBound(a, 2)) = a(i - 1, 2) & ";" & n n = n + 1 Loop End If Next VSortMA a, 2, UBound(a, 1), UBound(a, 2) rng.Value = a Erase a Last: End Sub Private Sub VSortMA(ary, LB, UB, ref) Dim M As Variant, temp i As Long, ii As Long, iii As Long i = UB: ii = LB M = ary(Int((LB + UB) / 2), ref) Do While ii <= i Do While ary(ii, ref) < M ii = ii + 1 Loop Do While ary(i, ref) > M i = i - 1 Loop If ii <= i Then For iii = LBound(ary, 2) To UBound(ary, 2) temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp Next ii = ii + 1: i = i - 1 End If Loop If LB < i Then VSortMA ary, LB, i, ref If ii < UB Then VSortMA ary, ii, UB, ref End Sub
- 締切済み
- Visual Basic
- エクセルVBAの繰り返し処理の質問
Ｃ列にある項目とＧ列にある項目を比較して、 一致し、Ｈ列にある数字が10以上ならば、Ｂ列にフラグ１を立てる という処理を行いたいんですが、 下記ぐらいまでしか作れず、うまくいきません・・・ Sub フラグを立てる処理() Dim i As Integer Dim j As Integer Dim k As Integer i = 1 j = 1 Do j = j + 1 Do i = i + 1 If Cells(j, 8) > 9 Then Cells(i - 1, 4) = 1 End If Loop Until Cells(i, 3) <> Cells(j, 7) Or Cells(i, 3) = "" Loop Until Cells(j, 7) = "" End Sub わかる方がいらっしゃいましたら、お願いします。
- 締切済み
- Visual Basic
- VBAで教えてください。
データがないときはExitSubしたいのですが、何処に記述すれば良いでしょうか？ Sub 削除() Dim i As Long If MsgBox("データを削除します。よろしいですか？", vbYesNo) = vbYes Then Sheets("リスト").Select i = 5 Do Until i = 200 If Cells(i, 5).Value = Sheets("マスタ登録").Range("D5") Then Cells(i, 1).EntireRow.Delete End If i = i + 1 Loop Else Exit Sub End If End Sub
- ベストアンサー
- オフィス系ソフト
- vba初心者
いつもお世話様です。 A列にあらかじめデータを入れといてinboxでデータを検索してもしあったらPDFファイルを開いて印刷でもしデータがなかったらinboxに戻るかたちにしたいんですけど、do...loopの使い方が分からないのと、デバックがでてしまってどう直せばいいかわかりません。サンプルコードがあれば助かります。よろしくお願いします。 Dim a As Integer Dim inbox As String Dim Localpath As Variant Dim c As Range, myFadd As String Dim flag As Variant Dim MyShell As Object Dim Mysh As String Dim newHour As Variant Dim newMinute As Variant Dim newSecond As Variant Dim waitTime As Variant Localpath = ThisWorkbook.Path a = 1 inbox = InputBox("番号") Do If inbox = Empty Then Exit Sub End If If inbox = Cells(a, 1) Then MsgBox ("あります") Exit Do Else a = a + 1 ←ここでデバックがでてしまいます。 ElseIf Cells(a, 1) <> inbox Then MsgBox ("ない") End If Loop Set MyShell = CreateObject("WScript.Shell") MyShell.Run ("AcroRd32.exe /n") MyShell.Run ("AcroRd32.exe /p") & Localpath & "\" & Myfile & ".pdf" newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 10 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime Application.SendKeys "{Enter}", True '次の使用例は、10 秒を過ぎるとメッセージを表示します。 If Application.Wait(Now + TimeValue("0:00:10")) Then MsgBox "時間が過ぎました。" End If End Sub
- ベストアンサー
- Visual Basic
- VBA実行時のエラー
下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。 このプログラムをシートから実行した所 エラー：400『既にフォームは表示されています。モーダルにできません。』 なるものが表示されてしまいます。 またコードを記述する所から実行しますと 実行時エラー：１００４『アプリケーション定義またはオブジェクト定義のエラー』 となってしまいます。 私の努力が足りないのは重々承知ですが、解決する事が出来ません。 皆様のお力を借りることが出来たらと思い投稿しました。 宜しくお願い致します。 Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "dem******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = Fales .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set WS1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destinaton:=Range("A1:A512") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = trFILENAME & "処理中..." Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 255 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 255 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 255 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 WS1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub
- ベストアンサー
- オフィス系ソフト
- vba 初心者
Dim a As Integer Dim inbox As String Dim Localpath As Variant Dim c As Range, myFadd As String Dim flag As Variant Dim MyShell As Object Dim Mysh As String Dim newHour As Variant Dim newMinute As Variant Dim newSecond As Variant Dim waitTime As Variant Localpath = ThisWorkbook.Path a = 1 inbox = InputBox("番号") Do If inbox = Empty Then Exit Sub End If If inbox = Cells(a, 1) Then MsgBox ("あります") Exit Do Else a = a + 1 ElseIf Cells(a, 1) <> inbox Then MsgBox ("ない") End If Loop Set MyShell = CreateObject("WScript.Shell") MyShell.Run ("AcroRd32.exe /n") MyShell.Run ("AcroRd32.exe /p") & Localpath & "\" & Myfile & ".pdf" newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 10 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime Application.SendKeys "{Enter}", True '次の使用例は、10 秒を過ぎるとメッセージを表示します。 If Application.Wait(Now + TimeValue("0:00:10")) Then MsgBox "時間が過ぎました。" End If End Sub ExcelからPDFファイルを検索して印刷したいのですが、 見よう見まねで作ってみたもののエラーが出てしまってよく分かりません。 指摘できるところご指導よろしくお願いします。
- 締切済み
- Visual Basic
- VBAが動きません。
VBAのコードが動きません。 エラーも出ないので、どこで動かないかわからずにいます。 どこに原因があるか教えていただけないでしょうか？ お手数ですが何卒よろしくお願いいたします。 ※画像参照 '①B列＜社員番号＞のフィルターを「（空白）」を外す '（1）F列＜住所都道府県＞のフィルターを「茨城・栃木・群馬・埼玉・千葉・東京・神奈川・新潟・山梨・長野・福島・大阪・兵庫」以外で設定 '（2）H列＜エリア＞のフィルターを「茨城・栃木・群馬・埼玉・千葉・東京・神奈川・新潟・山梨・長野・福島・大阪・兵庫」以外で設定 Sub フィルタ削除1_1() Dim pref As Variant pref = Array("茨城県", "栃木県", "群馬県", "埼玉県", "千葉県", "東京都", "神奈川県", "新潟県", "山梨県", "長野県", "福島県", "大阪府", "兵庫県", "静岡県") Dim r As Long, i As Integer, j As Integer For r = Cells(Rows.Count, 3).End(xlUp).Row To 4 Step -1 If Cells(r, "B") <> "" Then For i = 0 To UBound(pref) If InStr(Cells(r, "F"), pref(i)) > 0 Then Exit For End If Next i For j = 0 To UBound(pref) If InStr(Cells(r, "H"), pref(j)) > 0 Then Exit For End If Next j If (i > UBound(pref)) And (j > UBound(pref)) Then Rows(r).Delete End If End If Next r End Sub
- 締切済み
- Visual Basic