ウォッチ
お世話になります。
Excel2013でvbaを使ってシートの並べ替えを行いたいのですが、思い通りに並びません。
左のように並んだシートを右のように並べ替えたいです。
12.9 12.9
12.9(1) 12.9(1)
12.9(2) 12.9(2)
12.9(3) 12.9(3)
12.11 12.9(4)
12.9(4) 12.9(5)
12.10 12.9(6)
12.9(5) 12.9(7)
12.9(6) 12.9(8)
12.9(7) 12.9(9)
12.9(8) 12.9(10)
12.9(9) 12.9(11)
12.9(10) 12.9(21)
12.9(11) 12.10
12.9(21) 12.11
Sheet2 Sheet2
などがあります。小数である12.9や文字列である12.9(1)など入り混じっていることに加え、桁が1桁や2桁があります。
シート名の法則ですが、実際は日付になっています。よって、1.1~12.31までになります。それに同じ日付であれば括弧が付加されています。それ以外の文字のシートがあれば、最後に並んでいればよいです。
また、ひとつのブックには、基本同じ月のみです。例にある12は12のみで5.6などはありません。
いい案があればお願いします。
No.5ベストアンサー
- 回答日時：
No.3です。
ボケてました。
No.3はミスってます。
こちらに差し替えを。
Sub megu_2()
Dim re As Object, SL As Object
Dim ws As Worksheet
Dim i As Integer, ch As Boolean
Set re = CreateObject("VBScript.RegExp")
Set SL = CreateObject("System.Collections.SortedList")
For Each ws In Worksheets
ch = False
re.Pattern = "\.(\d+)$"
If re.Test(ws.Name) Then SL.Add Format(re.Replace(ws.Name, ""), "00") & _
Format(Val(re.Execute(ws.Name)(0).Submatches(0)), "00"), ws.Name: ch = True
re.Pattern = "\.(\d+)\((\d+)\)"
If re.Test(ws.Name) Then SL.Add Format(re.Replace(ws.Name, ""), "00") & _
Format(Val(re.Execute(ws.Name)(0).Submatches(0)), "00") & _
Format(Val(re.Execute(ws.Name)(0).Submatches(1)), "00"), ws.Name: ch = True
If ch = False Then SL.Add ws.Name, ws.Name
Next
If Worksheets(SL.GetByIndex(0)).Index <> 1 Then _
Worksheets(SL.GetByIndex(0)).Move Before:=Worksheets(1)
For i = 1 To SL.Count - 1
Worksheets(SL.GetByIndex(i)).Move After:=Worksheets(i)
Next
Set re = Nothing
Set SL = Nothing
End Sub
No.3は月が１桁の時ミスります。
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/10 14:25
ありがとうございました。
今の所完全には理解できませんでしたが、何となくざっきるわかりました。
SortedListがキーですね。今回初めて見ました。
正規表現で、シート名のパターンによって形を整えてSortedListに追加していき最後にリストに沿ってシート移動しているイメージですかね？
大変参考になりました。
No.10
- 回答日時：
今更ですが、鈍くさいけど分かりやすい方法で。
Sub Sample()
Dim rng As Range
Dim wb As Workbook
Dim i As Long
With ThisWorkbook.Worksheets("Sheet2")
.Columns(1).Copy .Columns(2)
With .Columns(2)
.Replace What:="(", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:=")", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
.TextToColumns Destination:=.Offset(, 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="."
End With
On Error Resume Next
.Columns(5).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "0"
On Error GoTo 0
Set rng = .Range("A1").CurrentRegion
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rng.Columns(4) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rng.Columns(5) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set wb = Workbooks("並べ替えるブック.xlsx")
On Error Resume Next
For i = 1 To rng.Rows.Count
wb.Worksheets(.Cells(i, 1).Text).Move After:=wb.Worksheets(wb.Sheets.Count)
Next
On Error GoTo 0
End With
End Sub
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/10 11:25
ありがとうございます。
確認しました。ざっくり動きを確認し、スマートではないですが素人には一番分かりやすく理解できそうな方法だと思いました。実際に使うとしたら、シート名をセル上に抜き出す必要があるので、その過程で、10（日）が１(日)と表示されてしまうので、そこで順番が狂ってしまうので、その対策が必要になってきます。
参考になりました。
No.9
- 回答日時：
実行時エラーの補足を頂いたのに返信が遅くなりすみませんでした。
補足について、使用しているAPIは64bit、32bit共に大丈夫そうです。検証した私のOfficeは32bitです。
Wb.Sheets.Countについては、Wb.Activateで該当ブックをアクティブにしているので要らないかと、思います。
さらに、
Wb.Sheetsも Sheets(～ の様にしても問題ないかと、、エラーから見直したので、すみません残してしまいました。
Set Wb = Workbooks("XXXX.xlsx") の部分で Withを使い括ってしまうと思ったのですが、
現状プロセスがどこでSet Wb しているか分からなかったので、取り敢えずWb.Activateで逃げました。
書き方はいくつかあると思います。
＃１の参考サイトに引っ張られ ＃２の回答、自ブックで処理して出来たとしても、やっつけ感否めなく、申し訳ないです。
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/10 11:59
この度は、ありがとうございました。
このコードは、StrCmpLogicalWがキーとなっているようですね。
StrCmpLogicalWの部分は、おまじない的に受け取れば、ざっくりとした流れは分かりました。
StrCmpLogicalWを使うことで、シンプルな構成で作られていることが分かりました。
PC環境によっては影響を受けそうですが、ほとんどの場合は大丈夫そうですね。
勉強になりました。
No.8
- 回答日時：
#2です 他のブックなのですね
エラーが返るとのことで書き換えてみました。
Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Sub API_sort()
Dim i As Long, j As Long, k As Long
Dim tmp As String
Dim ShtAry()
Dim Wb As Workbook
Application.ScreenUpdating = False
Set Wb = Workbooks("XXXX.xlsx")
Wb.Activate
ReDim ShtAry(1 To Sheets.Count)
For i = 1 To Sheets.Count
ShtAry(i) = Wb.Sheets(i).Name
Next i
For i = LBound(ShtAry) To UBound(ShtAry)
For j = i To UBound(ShtAry)
If StrCmpLogicalW(StrConv(ShtAry(i), vbUnicode), StrConv(ShtAry(j), vbUnicode)) > 0 Then
tmp = ShtAry(i)
ShtAry(i) = ShtAry(j)
ShtAry(j) = tmp
End If
Next j
Next i
For i = 1 To Sheets.Count
Wb.Sheets(ShtAry(i)).Move After:=Wb.Sheets(i)
Next i
Application.ScreenUpdating = True
End Sub
XXXX.xlsxは、ターゲットブック名で
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/10 15:29
本当にありがとうございました。
API使っていますが、結果シンプルにまとまっていて良いコードだと思いました。
だいぶ迷ったのですが、申し訳ないですが、先に回答して頂いためぐみん_さんにベストアンサーを選ばせていただきました。
No.7
- 回答日時：
No.6の補足に対して。
シート名の付け方は
＞2.9(4)
なのか
＞2.10 (10)
なのかで結果が違うのでしょうね。
すなわち半角文字の ( の左に半角スペース文字の有無で正規表現による番号抽出が出来るか否かは変わります。
確かに普通にＳｈｅｅｔを追加するとExcelは半角スペースを間に挟みますしね。
No.5の
＞re.Pattern = "\.(\d+)\((\d+)\)"
を
re.Pattern = "\.(\d+)\s?\((\d+)\)"
として貰えれば半角スペースの有無は関係なく並び変わります。
ただしシート名が
2.9(2)
2.9 (2)
と半角スペースを除くと同じ名前になってしまう物が双方存在した場合はエラーになりますけど、そういう状況も実際あり得ますでしょうか？
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/07 22:50
すみません。最後に変な補足を行いましたが、こちらのミスでした。ミスを修正したら正しく動作しました。
№5のコードでre.Pattern = "\.(\d+)\s?\((\d+)\)"
に差し替えで問題なさそうです。
ありがとうございます。
No.6
- 回答日時：
No.5の補足に対して。
そのシート名で試してみました。（No.5のコードのままで）
こちらでは、
2.9
2.9(1)
2.9(2)
2.10
2.10(10)
2.10(11)
2.10(21)
2.20
となりましたけど・・・？
全体を差し替えて頂けてますよね？
-
-
- 0
- 件
-
No.4
- 回答日時：
No.3です。
同じ月内ってことであれば
＞re.Pattern = "\.(\d+)\((\d+)\)"
＞If re.Test(ws.Name) Then SL.Add Format(re.Replace(ws.Name, ""), "00") & _
を
re.Pattern = "\.(\d+)\((\d+)\)"
If re.Test(ws.Name) Then SL.Add re.Replace(ws.Name, "") & _
でいけるかな？
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/06 21:59
こちらもありがとうございました。
こちらは、少し結果が違いました。できたかと思ったのですが、並びが12.9,12.9(1), 12.9(11), 12.9(12), 12.9(2), 12.9(21), 12.9(22),12.10,12.11となりました。№3の方で大丈夫でした。
ありがとうございます。
No.3
- 回答日時：
初級レベルなので勘違いをしているかもですが。
これってセルを並び替えるとか値を使用してって事に拘らないのですよね？
単にシート名でＳｈｅｅｔを並び替えればよいと思ったのですが、違っていたらスル～してください。
Sub megu()
Dim re As Object, SL As Object
Dim ws As Worksheet
Dim i As Integer, ch As Boolean
Set re = CreateObject("VBScript.RegExp")
Set SL = CreateObject("System.Collections.SortedList")
For Each ws In Worksheets
ch = False
re.Pattern = "\.(\d+)$"
If re.Test(ws.Name) Then SL.Add re.Replace(ws.Name, "") & _
Format(Val(re.Execute(ws.Name)(0).Submatches(0)), "00"), ws.Name: ch = True
re.Pattern = "\.(\d+)\((\d+)\)"
If re.Test(ws.Name) Then SL.Add Format(re.Replace(ws.Name, ""), "00") & _
Format(Val(re.Execute(ws.Name)(0).Submatches(0)), "00") & _
Format(Val(re.Execute(ws.Name)(0).Submatches(1)), "00"), ws.Name: ch = True
If ch = False Then SL.Add ws.Name, ws.Name
Next
If Worksheets(SL.GetByIndex(0)).Index <> 1 Then _
Worksheets(SL.GetByIndex(0)).Move Before:=Worksheets(1)
For i = 1 To SL.Count - 1
Worksheets(SL.GetByIndex(i)).Move After:=Worksheets(i)
Next
Set re = Nothing
Set SL = Nothing
End Sub
-
-
- 0
- 件
-
この回答へのお礼
お礼日時：2020/05/06 21:48
セルを並び替えるとか値を使用してって事に拘わりません。
試しました。
完璧でした。できました。
ありがあとうございます。助かりました。
No.2
- 回答日時：
#1です。
参考サイトを一応検証しましたが、すみません。12.9 の時、エラーが返りますね。シート名なので.Value でなく .Text に（2か所）変えると良いですが、
以前回答に使ったAPIのバブルソートがあったので、参考に少し改造してみました。
ご希望の様になりますか？
標準モジュールです。
Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Sub API_sort()
Dim i As Long, j As Long, k As Long
Dim tmp As String
Dim ShtAry()
Application.ScreenUpdating = False
With Sheets.Add
For i = 1 To Sheets.Count
.Cells(i, 1) = Sheets(i).Name
Next i
ShtAry = .Range("A1:A" & Sheets.Count).Value
For i = LBound(ShtAry) To UBound(ShtAry)
For j = i To UBound(ShtAry)
If StrCmpLogicalW(StrConv(ShtAry(i, 1), vbUnicode), StrConv(ShtAry(j, 1), vbUnicode)) > 0 Then
tmp = ShtAry(i, 1)
ShtAry(i, 1) = ShtAry(j, 1)
ShtAry(j, 1) = tmp
End If
Next j
Next i
.Cells.Clear
.Range("A1:A" & Sheets.Count).Value = ShtAry
Sheets(.Cells(1, 1).Text).Move Before:=Sheets(1)
For i = 2 To Sheets.Count
Sheets(.Cells(i, 1).Text).Move After:=Sheets(i - 1)
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub
-
-
- 0
- 件
-
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！
似たような質問が見つかりました
- Excel（エクセル） Excel>マクロ＞特定のセルで同じ情報が登録されている行を1行にまとめたい（文字連結） 6 2023/01/05 16:30
- Excel（エクセル） 棚卸表の前月比の関数等あれば教えてください 2 2023/05/02 18:34
- Visual Basic（VBA） Excel VBA 最終行を取得しVlookup関数をコピーする方法をコーディングで教えてください。 3 2023/05/11 13:14
- Excel（エクセル） 関数EXACT(文字列,文字列)とexcelVBA 3 2022/04/14 15:07
- その他（Microsoft Office） 1の行を固定した上でVBAを用いて日付順に自動並べ替え 2 2022/06/06 15:09
- Visual Basic（VBA） VBA 検索と入力 Excel ブック ぶぶぶ シート ししし 列V 検索対象の列です 最終行は、お 6 2023/05/17 01:40
- その他（Microsoft Office） エクセルで串刺ししたシートの並べ替えをしたいです 4 2023/02/14 11:59
- Visual Basic（VBA） EXCEL VBA 単語置き換え について質問です ブック名 ぶぶぶ シート名 ししし セル V３〜 3 2023/03/08 01:41
- Excel（エクセル） vba シートの並び替え 1 2023/04/19 13:44
- Google Drive Googleスプレッドシートについて質問です。 今作っているデータで、 シート1→ベタ打ちでひたすら 2 2022/05/18 14:27
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルの関数について教えて...
-
エクセルを共有するとPCによっ...
-
エクセルの関数 ＥＮＴＥＲを押...
-
VBAでブックを非表示で開いて処...
-
北九州市にあった「井筒屋ブッ...
-
WorkBooksをオープンさせずにシ...
-
シート３枚あるはずが１枚しか...
-
Excelでブックの共有を掛けると...
-
行、列の挿入がリンク先に反映...
-
【ExcelVBA】シートをそれぞれ...
-
エクセルで50行ごとに区切った...
-
Excel VBAでブックを閉じる時、...
-
EXECLの変更を保存せずにブック...
-
Excelで、複数ブックの複数シー...
-
エクセルで別ブックをバックグ...
-
リンク元ブックのPWが分からな...
-
VBA: ブックをアクティベイトで...
-
外部ブック参照が#REF!になって...
-
エクセルで参照しているデータ...
-
captionの値と実際の表示名が合...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルを共有するとPCによっ...
-
エクセルの関数 ＥＮＴＥＲを押...
-
VBAでブックを非表示で開いて処...
-
WorkBooksをオープンさせずにシ...
-
Excelでブックの共有を掛けると...
-
エクセルで参照しているデータ...
-
Excel（2010）のフィルターが保...
-
Excelで複数ブックの同一セルに...
-
VBA バックグラウンドで別ブッ...
-
エクセルで50行ごとに区切った...
-
エクセルで「ディスクがいっぱ...
-
エクセルにおける，「ブック」...
-
エクセルファイルを開かずにpdf...
-
フォルダ内の複数ファイルから...
-
ブックのピボットを別ブックに...
-
エクセルシートの一部を送りたい
-
エクセル２０１６です。「ブッ...
-
エクセルで別ブックをバックグ...
-
フォルダ内の複数ファイルから...
-
複数ファイルから特定シートの...
おすすめ情報
早速ありがとうございます。
試してみましたが、実行時エラー９になります。インディクスが有効範囲にありません。となりました。
wb.Sheets(.Cells(1, 1).Text).Move Before:=wb.Sheets(1)
実際は、wbをつけて、他のシートに対して操作しています。
Sheet2には、対象のシート名がA1から抜き出してあります。
エラーになるので、
wb.Sheets(.Cells(1, 1)).Select
を一つ前に入れて試すと、（質問時より多少シート数が増えて並びも違います。）何故か、12.9(10)シートのA1セルに移動しました。
意味がよくわかりません。
気になるのが、このやり方は質問前にこのコードの元となるものを試したのですが、シート名をセルに抜き出すと12.10が12.1として抜き出されてしまいます。結果、順番に反映されなかたりしました。
これもすでに試していました。
先に№２の回答のみをみて補足しました。
数字と文字のシートが混在の扱いの中では、だめですね。
意外と難しい。
wb.Sheets(1)側は、並び替えるシートの頭をつかんでいましたので問題なさそうです。
wb.Sheets(.Cells(1, 1).Text)では実行時エラー9になっています。
イミディエイトウィンドウの結果 ?wb.Sheets(.Cells(1, 1).value).name は 12.9(10) でした。
そして、.Range("A1:A" & Sheets.Count).Value = ShtAry 後の順番ですが、12.10が12.1となって先頭に来ていました。他の並びは問題ありませんでした。最後に0がつくものはだめです。
お手数をおかけしますが、宜しくお願いします。
ありがとうございます。
№３で完璧だと思っていたのですが、確認不足でした。
これを試してみました。
2月でためしたのですが、2.9,2.9(1),2.9(2), 2.10, 2.20, 2.10(10),2.10(11),2.10(2),2.10(21)
となってしまい、少し並びが№4ぽくなってしまいました。
そうなんですか？、全体を差し替えたのですが、一部端折ってましたので、実際に試した全結果の並び順です。前回補足に入れていた10(2)がないですね。それがなければ、一見正しく動作したように見えますが、以下のようなシートで試すとこの順番になりました。
お手数をおかけいたしますが、ご教授おねがいします。
2.9
2.9(1)
2.9(2)
2.9(3)
2.9(4)
2.10
2.20
2.10 (10)
2.10 (11)
2.10 (12)
2.10 (13)
2.10 (14)
2.10 (2)
2.10 (21)
2.10 (3)
2.10 (4)
2.10 (5)
2.10 (6)
2.10 (7)
2.10 (8)
2.10 (9)
確認しました。シート前の半角スペースの有無を考慮していませんでした。
同じ名前があれば、シート名をExcelvbaで()に番号をつけて作成するよう行っていましたが、そこには半角スペースを入れていませんでした。
で、1桁月の確認時に二つの状態が混在した為に、今回のような思い通りに並ばない結果につながってしまいました。
お手数をおかけしました。
2.9(2)
2.9 (2)
混在でエラーになることを確認しました。
この度、Excelvbaでシート作成時、すでに名前があれば半角スペース+括弧付きになるように変更しました。よって、今後はシートを手動でコピーしてもvbaで自動作成しても必ず半角スペースが入るので混在することはないと思います。
半角スペース有りで統一すると、確かに希望通りの並びに動作しました。問題なさそうです。
大丈夫だと思ったのですが、実際に使うもので試し12月はokで、2月で試すと何故か以下の順番になりました。何故か2.9が最後になってしまいました？？
2.9 (2)
2.9 (3)
2.9 (4)
2.9 (5)
2.9 (6)
2.9 (7)
2.9 (8)
2.9 (9)
2.9 (10)
2.9 (11)
2.9 (12)
2.9 (21)
2.9 (22)
2.9
ちなみに、他のシートで試した時は、
2.9
2.9 (2)
2.9 (3)
2.9 (10)
2.10
2.10 (2)
2.10 (3)
2.10 (4)
になりますが、使うシートでやると2.9が最後に。違いは、使うシートは、別のブックに対して操作を行っている点にあります。上の名はどちらもイミディエイトウィンドウでそのままシート名を抜き出したもので、2.9に差異は見られません。その他も半角スペース有りになっています。
64ビット版のExcelでざっと確認しましたが、問題なさそうです。ありがとうございます。
大変恐縮ですが、Wb.Activateしているので問題ないのですが、もし、誰かがこのコードを見て他のブックに対して使うことがあれば、Sheets.Count→Wb.Sheets.Count になるかと思います。3か所あります。
よく分からなのですが、APIの宣言が入っているので、32ビット版Excelでも動くかどうか明日確認したいと思います。64も32も関係ないですかね？
すでに32ビット版で動いているとのことであれば大丈夫ですかな。
Wbの件は承知しました。
もうお一方の方からも回答頂き、正規表現を使って実現してこちらも動作okでした。
自分で改造できるのが良いのですが、どちらも今の自分には難しい内容になっており理解することが厳しそうですが、もう少し時間をとって、動きと内容を確認して、どちらを使うかを決めたいと思います。
とりあえず、解決に結びついたのでありがとうございました。