Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8714 / 13646 ツリー ←次へ | 前へ→

【31620】文字の抽出からコピー 超ビギナー 05/11/27(日) 13:32 質問[未読]
【31623】Re:文字の抽出からコピー とまと 05/11/27(日) 13:46 回答[未読]
【31624】Re:文字の抽出からコピー とまと 05/11/27(日) 13:51 発言[未読]
【31625】Re:文字の抽出からコピー 超ビギナー 05/11/27(日) 14:02 質問[未読]
【31626】Re:文字の抽出からコピー とまと 05/11/27(日) 14:24 回答[未読]
【31627】Re:文字の抽出からコピー 超ビギナー 05/11/27(日) 14:45 質問[未読]
【31628】Re:文字の抽出からコピー とまと 05/11/27(日) 14:56 回答[未読]
【31630】Re:文字の抽出からコピー 超ビギナー 05/11/27(日) 15:03 お礼[未読]
【31631】Re:文字の抽出からコピー ichinose 05/11/27(日) 15:06 発言[未読]
【31632】Re:文字の抽出からコピー とまと 05/11/27(日) 15:20 発言[未読]
【31633】Re:文字の抽出からコピー kobasan 05/11/27(日) 15:32 発言[未読]
【31634】Re:文字の抽出からコピー 超ビギナー 05/11/27(日) 15:42 お礼[未読]

【31620】文字の抽出からコピー
質問  超ビギナー  - 05/11/27(日) 13:32 -

引用なし
パスワード
   1つの列に入力されているデーターの内、()で囲まれた内容のみを
他の列に移動させたいのですがどのようにすれば可能なのでしょうか?
尚、移動させるときは行を変更せずに移動させたいです。

一応、この質問箱の内容で近いものを試してみたのですがうまくいきま
せんでした。宜しくお願いします。

【31623】Re:文字の抽出からコピー
回答  とまと  - 05/11/27(日) 13:46 -

引用なし
パスワード
   こんにちは 
置換しています。A列のデータをB列に移動します。
括弧の種類違ったら適当に増やしてください。

Sub test()

Columns("A").Copy Range("B1")
Columns("B").Replace "*(", ""
Columns("B").Replace ")*", ""

End Sub

【31624】Re:文字の抽出からコピー
発言  とまと  - 05/11/27(日) 13:51 -

引用なし
パスワード
   ちょっと訂正。

Sub test2()

Columns("A").Copy Range("B1")
Columns("B").Replace "*(", "", xlPart
Columns("B").Replace ")*", "", xlPart

End Sub

【31625】Re:文字の抽出からコピー
質問  超ビギナー  - 05/11/27(日) 14:02 -

引用なし
パスワード
   とまとさん早々の回答ありがとうございます。

早速試してみたのですが、カッコが入力されていないセルの
内容もコピー貼り付けされてしまいます。

カッコが入力されているセルのみ移動させたいのですがどうし
たらよいのでしょうか?

もう一度ご教授願えませんでしょうか。
宜しくお願いします。
 

【31626】Re:文字の抽出からコピー
回答  とまと  - 05/11/27(日) 14:24 -

引用なし
パスワード
   A列にあるものをB列に出力しています。
適宜変更してみてください。

Sub 移動()

Dim vntA
Dim a As Long, b As Long, i As Long

          '↓適宜変更
vntA = Range("A1", [A65536].End(xlUp)).Value
      '↑適宜変更
      
For i = 1 To UBound(vntA)
If InStr(vntA(i, 1), "(") > 0 Then
  a = InStr(vntA(i, 1), "(")
  b = InStr(vntA(i, 1), ")")
  vntA(i, 1) = Mid(vntA(i, 1), a + 1, b - a - 1)
Else
  vntA(i, 1) = Empty
End If
Next

Range("B1").Resize(UBound(vntA)).Value = vntA
    '↑適宜変更

End Sub

【31627】Re:文字の抽出からコピー
質問  超ビギナー  - 05/11/27(日) 14:45 -

引用なし
パスワード
   またまたありがとうございます。

試してみたのですが移動やコピー等の変化が
何も起こりません。
私の質問が悪く意図が伝わっていなかったら
申し訳ありません。

    A列  B列
1行目 (ABCD) (ABCD)
2行目 BGDT
3行目 (XYZ)  (XYZ)
4行目 1234

上記の様にカッコのあるセルのみA列からB列へ移動させます。
B列に移動させたものはA列から削除できれば完璧です。

何度も質問で申しありませんが宜しくお願いします。

【31628】Re:文字の抽出からコピー
回答  とまと  - 05/11/27(日) 14:56 -

引用なし
パスワード
   ▼超ビギナー さん:
 
勘違いしてました。関数でもできそうだけど。。
これでどうです?


Sub 移動4()

Dim i As Long
Dim ck1 As Long, ck2 As Long

For i = 1 To [A65536].End(xlUp).Row
  ck1 = InStr(Cells(i, "A").Value, "(")
  ck2 = InStr(Cells(i, "A").Value, "(")
  If ck1 > 0 Or ck2 > 0 Then
   Cells(i, "B").Value = Cells(i, "A").Value
  End If
Next
 
End Sub

【31630】Re:文字の抽出からコピー
お礼  超ビギナー  - 05/11/27(日) 15:03 -

引用なし
パスワード
   とまとさん

できました。

長々とお付き合いいただきありがとうございました。

【31631】Re:文字の抽出からコピー
発言  ichinose  - 05/11/27(日) 15:06 -

引用なし
パスワード
   とまと さん、超ビギナー さん
こんにちは。

アルゴリズムを駆使すればできそうですけど
正規表現を使用するとあまり考えなくても
この手のことが実現出来ますよ!!

標準モジュールに
'=========================================
Dim regex As Object
Sub test()
  Set regex = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  For idx = 1 To Cells(Rows.Count, 1).End(xlUp).Row
   jdx = 0
   If Cells(idx, 1).Value <> "" Then
    ans = spfind(Cells(idx, 1).Value, "\([^\(^\)]*\)")
    Do Until ans = ""
     Cells(idx, jdx + 2).Value = ans
     jdx = jdx + 1
     ans = spfind
     Loop
    End If
   Next idx
  Set regex = Nothing
End Sub
'=====================================================================
Function spfind(Optional chkstr = "", Optional fstr = "") As String
  Static matches As Object
  Static cnt As Long
  spfind = ""
  With regex
   If chkstr <> "" Then
     Set matches = Nothing
     .Pattern = fstr
     .IgnoreCase = True
     .Global = True
     Set matches = .Execute(chkstr)
     cnt = 0
     End If
   If cnt < matches.Count Then
    spfind = matches(cnt)
    cnt = cnt + 1
    End If
   End With
End Function

これでアクティブシートのA列の()「()も含む」内を抜き出して
B列以降に記述します。

尚、検索対象の()は、半角です。

【31632】Re:文字の抽出からコピー
発言  とまと  - 05/11/27(日) 15:20 -

引用なし
パスワード
   ▼ichinose さん:

正規表現はまだ手をだしていないのですが、
興味ありです(^^
質問しているのを見かけたらご指導ください。
今回のは括弧の中とか関係ないみたいですね。
あせって回答してしまいました。(^^;

関数はりつけるぐらいでも大丈夫そう。。

Sub 移動5()

With Range("A1", [A65536].End(xlUp)).Offset(, 1)
.Formula = "=IF(ISERROR(FIND(""("",A1)),"""",A1)"
.Value = .Value
End With

End Sub

では。

【31633】Re:文字の抽出からコピー
発言  kobasan  - 05/11/27(日) 15:32 -

引用なし
パスワード
   皆さん 今日は。

わかりやく、簡単な方法で、私も。

Sub test2()
Dim r As Range
  For Each r In Range("a1", Range("A65536").End(xlUp))
    If r.Text Like "*(*)*" Then
      r.Offset(, 1) = r.Value
      r.ClearContents
    End If
  Next
End Sub

【31634】Re:文字の抽出からコピー
お礼  超ビギナー  - 05/11/27(日) 15:42 -

引用なし
パスワード
   みなさんありがとうございます。

大変勉強になりました。

最近仕事で色々と作らせられて。。。←無理やり(ToT)

今後も質問させてもらうかと思いますので、そのときには
宜しくお願い致します。

ありがとうございました。

8714 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free