Excel VBA質問箱 IV

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

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


15820 / 76738 ←次へ | 前へ→

【66393】Re:()間の文字の抽出について
回答  UO3  - 10/9/2(木) 18:22 -

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

こんにちは

SampleB の 別案です。
A列以外に (Table. ○○○) があると、A列のものと同等にみなされてしまいますが。

Option Explicit

Dim sh3 As Worksheet
Dim row3 As Long

Sub SampleB_2()
Dim allV As Variant
Dim allStr As String
Dim tblAv As Variant  'Table名の配列 転記シートA列用
Dim i As Long, j As Long, k As Long, x As Long, z As Long
Dim myC As Range

 z = WorksheetFunction.CountA(ActiveSheet.UsedRange)
 If z = 0 Then
  MsgBox "このシートは空白シートです"
  Exit Sub
 End If
 
 Application.ScreenUpdating = False
 allV = Array("") '配列化
 ReDim allV(1 To z)
 Set sh3 = Worksheets("SHeet3")
 sh3.Columns("A:C").ClearContents
 tblAv = Array("") '初期化
 z = 0
 
 For Each myC In ActiveSheet.UsedRange
  If Not IsEmpty(myC.Value) Then
   z = z + 1
   allV(z) = myC.Value
  End If
 Next
 
 Set myC = Nothing
 allStr = Join(allV, ",")
 allStr = Replace(allStr, "(Table.", vbTab & vbCr)
 allStr = Replace(allStr, ")", vbTab)
 allStr = Replace(allStr, "(", vbTab & vbLf)
 allV = Split(allStr, vbTab)
 
 For z = LBound(allV) To UBound(allV)
  If Left(allV(z), 1) = vbCr Then
   Call tblSet(Mid(allV(z), 2), tblAv)
  ElseIf Left(allV(z), 1) = vbLf Then
   Call itemSet(Mid(allV(z), 2), tblAv)
  End If
 Next
 
 sh3.UsedRange.NumberFormatLocal = "@"
 Set sh3 = Nothing
 Set myC = Nothing
 Application.ScreenUpdating = True
 
End Sub

Private Sub tblSet(ByVal myStr As String, ByRef tblV As Variant)
Dim x As Long
 tblV = Split(myStr, ",")
 For x = LBound(tblV) To UBound(tblV)
  tblV(x) = WorksheetFunction.Trim(tblV(x))
 Next
End Sub

Private Sub itemSet(ByVal myStr As String, ByRef tblAv As Variant)
 Dim itemV As Variant  '( ) 内の要素の配列
 Dim tblBV As Variant  'Table名の配列 転記シートB列用
 Dim x As Long, z As Long, i As Long, j As Long, k As Long
 Dim v As Variant
 Dim s As String
 tblBV = Array("")
 x = InStr(myStr, ";")
 If x > 0 Then
  z = InStr(x, myStr, "Table.")
  If z > 0 Then
   Call tblSet(Mid(myStr, z + 6), tblBV)
   myStr = Left(myStr, x - 1)
  End If
 End If
 itemV = Split(myStr, ",")
 For x = LBound(itemV) To UBound(itemV)
  itemV(x) = WorksheetFunction.Trim(itemV(x))
 Next
 For i = LBound(tblAv) To UBound(tblAv)
  For j = LBound(tblBV) To UBound(tblBV)
   For k = LBound(itemV) To UBound(itemV)
    row3 = row3 + 1
    sh3.Range("A" & row3).Value = tblAv(i)
    sh3.Range("B" & row3).Value = itemV(k)
    sh3.Range("C" & row3).Value = tblBV(j)
   Next
  Next
 Next
End Sub
0 hits

【65808】()間の文字の抽出について なのは 10/6/29(火) 4:11 質問
【65809】Re:()間の文字の抽出について ichinose 10/6/29(火) 5:25 発言
【65813】Re:()間の文字の抽出について なのは 10/6/29(火) 9:27 質問
【65846】Re:()間の文字の抽出について Hirofumi 10/6/30(水) 13:56 回答
【65878】Re:()間の文字の抽出について なのは 10/7/4(日) 23:51 お礼
【66380】Re:()間の文字の抽出について UO3 10/9/1(水) 22:05 発言
【66382】Re:()間の文字の抽出について なのは 10/9/2(木) 6:51 発言
【66383】Re:()間の文字の抽出について かみちゃん 10/9/2(木) 8:59 発言
【66384】Re:()間の文字の抽出について UO3 10/9/2(木) 9:19 発言
【66385】Re:()間の文字の抽出について かみちゃん 10/9/2(木) 9:30 発言
【66389】Re:()間の文字の抽出について UO3 10/9/2(木) 15:35 発言
【66390】Re:()間の文字の抽出について UO3 10/9/2(木) 16:46 回答
【66392】Re:()間の文字の抽出について UO3 10/9/2(木) 17:26 発言
【66391】Re:()間の文字の抽出について かみちゃん 10/9/2(木) 17:22 発言
【66393】Re:()間の文字の抽出について UO3 10/9/2(木) 18:22 回答

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