• 締切済み

実行するとどうなるのでしょうか?

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

みんなの回答

回答No.1

実行してみりゃいいじゃん(笑)

関連するQ&A

  • エクセル自動改行で互換性エラー

    エクセルで、1行35文字以上が記入されると自動で次のセルに改行される 仕様になるようにマクロを組んでいます。 ただ自身はマクロ未経験で、他のところから見様見真似で コードを調整してくっつけただけで、知識はほとんどありません。 そのため、エクセルのバージョンが違うとうまく動作しないようになっています。 どこの記述がおかしいのか、足りないのかわかりません。 制作環境:excel 2010 以下内容です。 ------------------------------------------- ' 改行自動 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Dim TgRng As Range Dim N As Integer Dim Ary() Dim S As String Set TgRng = Range("N10:N26") Set Rng = Intersect(TgRng, Target) If Rng Is Nothing Then Exit Sub Application.EnableEvents = False With Rng.Cells(1) If Len(.Value) > 36 Then S = .Value For N = 0 To Int((Len(S) + 35) / 36) ReDim Preserve Ary(N) Ary(N) = Left(S, 36) S = Mid(S, 37) If S = "" Then Exit For Next .Resize(UBound(Ary) + 1).Value = Application.Transpose(Ary) End If End With Application.EnableEvents = True Set Rng = Nothing Set TgRng = Nothing Erase Ary End Sub ' 切り取り禁止 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Application.CutCopyMode = 2 Then Application.CutCopyMode = 0 End If End Sub -------------------------------------------

  • Excelの同時置換の置換場所指定

    以前、どなたかの質問の回答で… Sub MultiReplacement()  Dim MyWords As Variant  Dim MyRepWords As Variant  Dim Ans As Integer  Dim Rng As Range  MyWords = Array("A", "C") 'ここに検索語を入れてください。  MyRepWords = Array(1, 2) 'ここに置換語を入れてください。  '検索語と置換語を調べる  If UBound(MyWords) <> UBound(MyRepWords) Then   MsgBox "検索語数( " & UBound(MyWords) & _   " )と置換語数( " & UBound(MyRepWords) & " )数が違います。", 64   Exit Sub  End If    Set Rng = Selection 'マウスで範囲を選択してください。  If Rng.Count = 1 Then   Ans = MsgBox("セル1つしか選択されていませんが、よろしいですか?", vbYesNo)   If Ans = vbNo Then    Exit Sub   End If  End If  '実行  For i = LBound(MyWords) To UBound(MyWords)   Cells.Replace What:=MyWords(i), Replacement:=MyRepWords(i), _   LookAt:=xlPart, _   MatchCase:=True  Next i End Sub ------------------------ というものを出してくれた方が折られました。それでなのですが… 置換語の場所を指定する場合はこれをどの用にしたらよいのでしょうか?? たとえば、セルA1から並んでいる、りんご/みかん/めろん…を、ほかの列CにApple/Orange/Mellon…するには??教えてくださいませ。

  • マクロ実行後に操作を元に戻したい

    自作の時間割変更プログラムを使っています。 次のマクロを何度か実行した後に一つずつ元に戻したいのですが。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range Dim m, n, s On Error Resume Next If Selection.Count <> 2 Then Exit Sub m = ActiveCell.Value n = ActiveCell.Interior.ColorIndex For Each Rng In Selection If Rng.Address <> ActiveCell.Address Then ActiveCell.Value = Rng.Value ActiveCell.Interior.ColorIndex = Rng.Interior.ColorIndex Rng.Value = m Rng.Interior.ColorIndex = n End If Next Rng End Sub 時間割のコマを移動した後に間違いが見つかり、間違いの時点まで元に戻して訂正したいのですが、Ctrl+zがきかず困っています。 Excel 365、windows 10を使用しています。どうにかなりませんか?

  • 作成方法についての質問です。

    下記のマクロで実行すると添付画像[現状]のようになってしまいます。 私としては[こうなってほしい]の形にしたいのですが、どこに何を組み込めばよいかわかりません。 誰か教えてください。 Dim Matches As Object Dim Match As Object Dim i As Long, j As Long Dim a As Variant With CreateObject("VBScript.RegExp") Set rng = Range("A1", Cells(Rows.Count, 1).End(xlUp)) Application.ScreenUpdating = False For i = 1 To rng.Rows.Count If InStr(1, rng.Cells(i, 1).Value, "(", 1) > 0 Then .Pattern = "\(([A-z\d,]+)" Else .Pattern = "([A-z\d,]+)" End If .Global = True Set Matches = .Execute(StrConv(rng.Cells(i, 1).Value, vbNarrow)) If Matches.Count > 0 Then a = Matches(0).SubMatches(0) a = Split(a, ",") Cells(i, 2).Resize(, UBound(a) + 1).Value = a End If j = 0 Next End With Application.ScreenUpdating = True Set rng = Nothing End Sub

  • 重複行を完全削除するエクセルのマクロ

    Sub sakujyo() Dim i, ii As Long For i = 1 To Range("a65336").End(xlUp).Row For ii = Range("a65336").End(xlUp).Row To i + 1 Step -1 If Cells(i, 2).Value = Cells(ii, 2).Value _ And Cells(i, 4).Value = Cells(ii, 4).Value _ And Cells(i, 5).Value = Cells(ii, 5).Value Then Dim iii As Byte iii = 1 Rows(ii).Delete Shift:=xlUp End If Next ii If iii = 1 Then Rows(i).Delete Shift:=xlUp iii = 0 Next i End Sub データーが下の表のように入っております。     A    B    C    E    F 1  1/26  a1234  fdsa  5000  C1 2  1/27  a4567  sdfa  4000  T2 3  1/28  a1234  dfsa  5000  C1 4  1/30  b4567  asdf  6600  A2 5  2/10  b4567  fsda  6600  A2 6  2/10  a1234  afds  5000  C1 B列、E列、F列が完全一致(重複1行目と3行目と6行目・4行目と5行目)で削除し結果的に2行目だけ残る方法がしたいのですが、このマクロですと少ないデータですとうまく動くのですが、『大量のデータを一気に削除出来ない』、『同じ重複が3つ以上のデータが多数ある場合データが削除されずに残ってしまう』エラーが出てしまいます。どうかお教えください。

  • VBA 検索して一致したセルへジャンプさせたい

    Excelにて、シート1のA列とシート2のA列のデータにNoを入れます。 シート1のA列のNoをクリックすると、シート2のA列の同じNoにジャンプするマクロを組みたいです。 現在組んでいるマクロは、 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Sht As Worksheet Dim Rng1 As Range Dim Rng2 As Range Dim FindCell As Range Set Sht = Worksheets("シート2") Set Rng1 = Range("A2:A100") Set Rng2 = Sht.Range("A2:A100")If Intersect(Target, Rng1) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub Set FindCell = Rng2.Find(Target.Value) If Not FindCell Is Nothing Then Application.Goto Reference:=FindCell, Scroll:=False End If End Sub です。 一応マクロは実行されますが、そうすると、シート1のA列の編集(Noを追加したり変更したり・・・)できません。 編集や変更もできて、検索マクロも実行できるというマクロの組み方はありますでしょうか?

  • マクロ実行が遅い・・・

    皆さんにおしえてもらいながら下記のようなマクロを組みました。 しかし、マクロを実行すると計算中が長いのです。 もしこのマクロに原因があれば教えてください。 よろしくお願いします。 -------------------------- Sub 見積書作成() Sheets("見積書").Select '見積書シートを選択 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If Cells(i, 5).Value = "0" Then '工数が「0」のときは Rows(i).RowHeight = 0 '行高さ「0」 End If Next For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 Range("E8:E55") = Application.Round(Range("E8:E55"), 0) '工数を四捨五入 Next Dim Rng As Range Const Retu = "C" '<--- ここで「小計」の列を指定します。 For Each Rng In Range(Retu & "1", Range(Retu & "65536").End(xlUp)) If Trim(Rng.Value) = "小   計" And _ Rng.Offset(, 6) = 0 Then Rng.EntireRow.Hidden = True End If Next Rng End Sub

  • VBA実行時のエラー

    下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。 このプログラムをシートから実行した所 エラー:400『既にフォームは表示されています。モーダルにできません。』 なるものが表示されてしまいます。 またコードを記述する所から実行しますと 実行時エラー:1004『アプリケーション定義またはオブジェクト定義のエラー』 となってしまいます。 私の努力が足りないのは重々承知ですが、解決する事が出来ません。 皆様のお力を借りることが出来たらと思い投稿しました。 宜しくお願い致します。 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の記録を追加したい

    エクセル2002使用です。 VBAで次のコードを使っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Set Target = Intersect(Range("C:C"), Target) If Target Is Nothing Then Exit Sub For Each Rng In Target If Rng.Value <> "" Then Rng.Offset(, -2).Value = Now Else ' (*) Rng.Offset(, -2).Value = "" ' (*) End If Next Rng End Sub (C列のセルに何か入力されると、A列の同じ行にその時刻が入る。) 同じシートで、F列に何か入力されるとE列の同じ行にその時刻が入るように書き直したいのですが、どうすればいいのでしょうか? すいませんが、よろしくお願いします。

  • CollectionとArrayの呼び出し順

    こんばんは。 いつも勉強させてもらっています。 ご教授ください。 セル範囲A1:B3に適当な値を入れ 下記のコードを実行してみました。 ----------------------------------------------- Sub Test()   Dim Rng As Range   Dim myRange As Range   Set myRange = Range("A1").CurrentRegion     For Each Rng In myRange       Debug.Print "Collection: " & Rng.Value     Next Rng   Dim Ary   Dim myArray      myArray = Range("A1").CurrentRegion.Value     For Each Ary In myArray       Debug.Print "Array: " & Ary     Next Ary End Sub ----------------------------------------------- その結果、 Collectionの場合は、 A1>B1 >A2>B2 >A3>B3 Arrayの場合は、   A1>A2>A3 >B1>B2>B3 の順で呼び出されました。 なぜこのような違いがでるのか分かりません。 教えてください。 宜しくお願いします。