[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『文字列を抽出（ソート）』（ハイチ）
AシートのA列に文字列Jacs-***(3桁の数値)を含む文字列が複数行あります。
A
1 ------ Jacs-282 -----------------
2 ---Jacs-025 ------------------------------
3 --------- Jacs-120 ---------------
4 -----Jacs-005 -----------------
B列シートにAシートを対象に
A列にJacs-***を抽出（ソート）
B列にA列相当の文字列を配置したい
A B
1 Jacs-005 -----Jacs-005 -----------------
2 Jacs-025 ---Jacs-025 ------------------------------
3 Jacs-120 --------- Jacs-120 ---------------
4 Jacs-282 ------ Jacs-282 -----------------
参考VBAコードを教えてください。
又は、参考になるサイトの記事を紹介ください
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
1 B1にA1の文字列からJacs-***をコピペする。 2 Ctrl+Eでフラッシュコピー 3 昇順で並べ替え
（フォーキー） 2023/01/01(日) 09:52:17
>フラッシュコピー フラッシュフィルでした。すみません。 （フォーキー） 2023/01/01(日) 09:54:15
試してみましたが上手くJacs-***が抽出される場合とだめな場合があります。
（ハイチ） 2023/01/01(日) 11:22:21
Sub Macro1()
Dim wsA As Worksheet, wsB As Worksheet
Dim i As Long, n As Long
Set wsA = Worksheets("A")
Set wsB = Worksheets("B")
For i = 1 To wsA.Cells(Rows.Count, 1).End(xlUp).Row
n = InStr(wsA.Cells(i, 1), "J")
wsB.Cells(i, 1) = Mid(wsA.Cells(i, 1), n, 8)
wsB.Cells(i, 2) = wsA.Cells(i, 1)
Next
wsB.Range("A1").Sort key1:=wsB.Range("A1"), order1:=xlAscending
End Sub
（フォーキー） 2023/01/01(日) 12:10:03
すいませんが、実データーは、差支えがあるので見せる事はできません。
元データーに規則性（法則）が無いのが問題だと思います。
私がもたもたしている間にVBAのコードが貼られていたので
参考にしてコードを以下のように改造してみました。
改造点 ：
１）DATAシートからSortシートへの転記ではなく
一度直接データーをDATAシートからSortシートに貼り付けて処理するようにしました。
２）元データ（文字列）の最初の８文字間に"J"が必ず有るのでこれを削除する事にしました。
コードをテストすると以下で「オブゼクトが必要です」とエラーがでました。
これは、２）を行っているのですがエラー原因が分からないので教えてください。
Ws2.Cells(i, "B").Value = Mid(Ws2.Cells(i, "B"), 8).Value
'--------------------------------------------------------------
Sub Copy_and_Sort()
Dim lc As Long
Dim Ws1, Ws2 As Worksheet
Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Sort")
lc = Ws1.Cells(Rows.Count, "B").End(xlUp).Row
Ws2.Cells.Clear
Ws2.Range("B1:B" & lc).Value = Ws1.Range("B6:B" & lc).Value
Dim i, n As Long
For i = 1 To lc - 5
Ws2.Cells(i, "B").Value = Mid(Ws2.Cells(i, "B"), 8).Value
Next
For i = 1 To lc - 5
n = InStr(Ws2.Cells(i, "B"), "J")
Ws2.Cells(i, "A") = Mid(Ws2.Cells(i, "B"), n, 8)
Next
Ws2.Range("A1").Sort key1:=Ws2.Range("A1"), order1:=xlAscending
End Sub
（ハイチ） 2023/01/01(日) 13:24:52
Sub Macro1()
Dim wsA As Worksheet, wsB As Worksheet
Dim i As Long, j As Long, n As Long, buf As String
Set wsA = Worksheets("A")
Set wsB = Worksheets("B")
For i = 1 To wsA.Cells(Rows.Count, 1).End(xlUp).Row
Do Until buf = "Jacs"
j = n + 1
n = InStr(j, wsA.Cells(i, 1), "J")
buf = Mid(wsA.Cells(i, 1), n, 4)
Loop
wsB.Cells(i, 1) = Mid(wsA.Cells(i, 1), n, 8)
wsB.Cells(i, 2) = wsA.Cells(i, 1)
n = 0
buf = ""
Next
wsB.Range("A1").Sort key1:=wsB.Range("A1"), order1:=xlAscending
End Sub
（フォーキー） 2023/01/01(日) 13:57:59
教えていただいたように、InStr関数で検索を始める位置を指定すれば
ファイル名の頭を削る無駄な処理は要らないのが判りましたが
ファイル名の見やすい13:24の自前のコードを追求して
教えていただいたコードを参考に見直しました。
エラーが出るので仮のtemp変数を利用して処理するとエラーが出なくなりました。
又、必ずJacs-が存在する前提でしたが無い場合も存在していたので
ON Error Resume Next で処理を進行してどうにかソート処理まで終了しました。
アドバイスが無かったらこんなに早く解決しなかったと思います。
ご協力ありがとうございます。
（ハイチ） 2023/01/01(日) 16:13:20
InStr関数って、複数文字でもいけませんでしたっけ。 各セルに Jacs-*** が1つしかなく、8文字固定なら、
Dim str$, num& str = "Japan Jacs JJJJJacs-001" num = InStr(str, "Jacs-") Debug.Print Mid(str, num, 8)
（黒豆） 2023/01/01(日) 16:41:27
（フォーキー） 2023/01/01(日) 16:56:44
ハイチさんの 2023/01/01(日) 13:24:52 のコードを修正するなら下記のような感じでしょうか。
Sub Copy_and_Sort1()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Sort")
Dim lc As Long
lc = Ws1.Cells(Rows.Count, "B").End(xlUp).Row
Ws2.Cells.Clear
Ws2.Range("B1:B" & lc - 5).Value = Ws1.Range("B6:B" & lc).Value
Dim i, n As Long
For i = 1 To lc - 5
n = InStr(Ws2.Cells(i, "B"), "Jacs-")
If n > 0 Then Ws2.Cells(i, "A") = Mid(Ws2.Cells(i, "B"), n, 8)
Next
Ws2.Range("A1").Sort key1:=Ws2.Range("A1"), order1:=xlAscending
End Sub
（hatena） 2023/01/01(日) 17:17:22
InStr関数は、複数文字も対応との事なので修正しました。
（On Error Resume Next を使わなくて ifで存在をチェックする方確実ですね。）
一応、結果は出ているのですが 変数(temp)を利用して
フォルダー名を削る作業を行うとエラーが出て#N/AがB列の最下部に表示されます、
どうすれば、エラーが無くなりますか ？
コード的には以下の部分を参照ください。
'------------------------ この時点で ＃N/A が ５個 追加される
シート上では、以下のような表示となります。
A B 1 Jacs-005 -----Jacs-005 ----------------- 2 Jacs-025 ---Jacs-025 ------------------------------ 3 Jacs-120 --------- Jacs-120 --------------- 4 Jacs-282 ------ Jacs-282 ----------------- ＃N/A ＃N/A ＃N/A ＃N/A ＃N/A
'---------------- 以下現在のコード
Option Explicit
Sub ACopy_and_Sort()
'特定文字列の"Jacs-"が存在しない場合を想定してエラーが発生しても無視して処理を継続させる
'コードを見直してエラー処理を入れたのでこの処理は無効にした。
'On Error Resume Next
'シートをセット
Dim Ws1, Ws2 As Worksheet
Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Sort")
'処理行の総数
Dim lc As Long
lc = Ws1.Cells(Rows.Count, "B").End(xlUp).Row
'書き出しシートの初期化
Ws2.Cells.Clear
'DATAシートからSrotシートへファイル名をコピペ
Ws2.Range("B1:B" & lc).Value = Ws1.Range("B6:B" & lc).Value
'ファイル名の修正：先頭から９文字(フォルダー名)は必要ないので削除
'(直接変換するとエラーが出るので仮のtemp変数で一時退避して書き込む)
Dim temp As String
Dim i As Long
For i = 1 To lc - 5
temp = Mid(Ws2.Cells(i, "B"), 9)
Ws2.Cells(i, "B").Value = temp
Next
'------------------------ この時点で ＃N/A が ５個 追加される
' InStr関数は、複数文字も対応。
'指定文字列のJacs-の最初の文字である"Jacs-"の位置をサーチしてそこから８文字を抽出
'他のコードを検索するなら、"Jacs-"の部分を変更する事 !!
Dim n As Long
For i = 1 To lc - 5
n = InStr(Ws2.Cells(i, "B"), "Jacs-")
'セルに指定文字列が有る前提だけど無い場合を想定して <----- エラー処理
If n > 0 Then
Ws2.Cells(i, "A").Font.ColorIndex = 1 '文字色を黒色に設定
Ws2.Cells(i, "A") = Mid(Ws2.Cells(i, "B"), n, 8)
Else
Ws2.Cells(i, "A").Font.ColorIndex = 3 '文字色を赤色に設定
Ws2.Cells(i, "A") = "候補なし"
End If
Next
'A列でソート処理
Ws2.Range("A1").Sort key1:=Ws2.Range("A1"), order1:=xlAscending
MsgBox "ソート終了しました。"
End Sub
（ハイチ） 2023/01/03(火) 17:07:58
（abc） 2023/01/03(火) 17:35:29
hatenaさんのコードを見てください。
>Ws2.Range("B1:B" & lc - 5).Value = Ws1.Range("B6:B" & lc).Value
~~~~~
あと、これもhatenaさんが修正していますが、
>Dim Ws1, Ws2 As Worksheet
これだと、Ws1はVariant型になります。 複数の変数をまとめて型指定することはできません。 （フォーキー） 2023/01/03(火) 17:42:49
突然、フォルダー名という話がでてきた印象があるのですが、 どういう関係の話なのか、説明をされたほうがよいのでは？
abcさん、説明不足ですいません。
ファイル名(文字列)の先頭には、パス名に相当する部分が有ります。
これは、必要ないのでファイル名から削除しています。
（削る＝削除）
hatenaさんの修正をちゃんと理解していないで
自分なりの修正で済ませたので#N/Aが書き込まれていたのがやった理解できました。
フォーキーさん、気づかせていただきありがとうございます。
わからんさん、
「-」は、ハイフン（マイナス記号）です。
ハイフンの後に３桁の数字が続きます。
'----------------------------
お陰様で、コードを修正して#N/Aも表示されなくなりました。
これで完結したと思います。
（ハイチ） 2023/01/03(火) 18:52:04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.