[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『アルファベット以外の取得』（hai）
excel2010 windows 7
A列のアルファベット以外をB列に入力するマクロを教えてください。 範囲は行2からA列に入力のある範囲です。
A B
1 2 A1 1 3 AA1 1 4 A2 2 5 AAA2 2 6 A33 33 7 AA33 33
標準モジュールに
'===========================================================================
Option Explicit
Option Compare Text 'これも必須です
Sub samp()
Dim rng As Range
Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
With rng
If .Row > 1 Then
With .Offset(0, 1)
.Formula = "=except_alpha(rc[-1])"
.Value = .Value
End With
End If
End With
End Sub
'====================================================================
Function except_alpha(mydata As Variant) As String
Dim chkstr As String
Dim g0 As Long
except_alpha = ""
chkstr = mydata
For g0 = 1 To Len(chkstr)
If Mid(chkstr, g0, 1) Like "[!a-z]" Then
except_alpha = except_alpha & Mid(chkstr, g0, 1)
End If
Next
End Function
これでデータがあるシートをアクティブにして、sampを実行してみてください。
ichinose
ichinoseさんありがとうございます。 できました！が、内容不足でした。少し変えさせてください。
>A列のアルファベット以外をB列に入力するマクロを教えてください。 >範囲は行2からA列に入力のある範囲です。
G列のアルファベット以外をH列に入力してG列にはアルファベットのみを残すマクロ教えてください。 範囲は行2からG列に入力のある範囲です。 そのマクロとは別に、G列とH列に分解したデータをG列に合体させるマクロも教えて下さい。 たくさん注文入れてすいません。 (hai)
G列の２行目からデータがあるとして、標準モジュールに
'==================================================================
Option Explicit
Option Compare Text 'これも必須です
Sub samp()
Dim rng As Range
Set rng = Range("g2", Cells(Rows.Count, "g").End(xlUp))
With rng
If .Row > 1 Then
With .Offset(0, 1)
.Formula = "=except_alpha(rc[-1])"
.Value = .Value
End With
.Value = Evaluate("=if(" & .Address & "="""","""",SUBSTITUTE(" & _
.Address & "," & .Offset(0, 1).Address & ",""""))")
MsgBox "Ｇ列とＨ列をアルファベットとそれ以外に分けました。 確認してください"
.Value = Evaluate("=" & .Address & "&" & .Offset(0, 1).Address)
MsgBox "Ｇ列とＨ列を合体させました"
End If
End With
End Sub
'====================================================================
Function except_alpha(mydata As Variant) As String
Dim chkstr As String
Dim g0 As Long
except_alpha = ""
chkstr = mydata
For g0 = 1 To Len(chkstr)
If Mid(chkstr, g0, 1) Like "[!a-z]" Then
except_alpha = except_alpha & Mid(chkstr, g0, 1)
End If
Next
End Function
これで当該シートをアクティブにした状態でsampを実行して下さい。 分けるのと合体を同時に行っています。
実際の運用に当たっては、コードを解析して、使ってください。
ichinose
これは [[20100812015618]] の延長ですわなぁ？ だったら並べ替えもすべてマクロでやってしもたらどうでっか？ こっちかな。 ''''''''''''''''''''''''''''''''''''''' Sub hai() Dim i As Long, tbl tbl = Range("a2").Resize(Range("a" & Rows.Count).End(xlUp).Row - 1) Application.ScreenUpdating = False With CreateObject("vbscript.regexp") .Pattern = "(\D+)(\d+)" For i = 1 To UBound(tbl, 1) If .test(tbl(i, 1)) Then tbl(i, 1) = .Replace(tbl(i, 1), "$1") & Format(.Replace(tbl(i, 1), "$2"), "0000") End If Next i Range("b2").Resize(UBound(tbl, 1)) = tbl Range("b2").Resize(UBound(tbl, 1)).Sort key1:=Range("b2"), order1:=xlAscending tbl = Range("b2").Resize(UBound(tbl, 1)) .Pattern = "(0)*(\d+)" .Global = True For i = 1 To UBound(tbl, 1) If .test(tbl(i, 1)) Then tbl(i, 1) = .Replace(tbl(i, 1), "$2") End If Next i End With Range("b2").Resize(UBound(tbl, 1)) = tbl Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''
それともこっち？
''''''''''''''''''''''''''''''''''''
Sub haiこっち()
Dim i As Long, tbl
tbl = Range("a2").Resize(Range("a" & Rows.Count).End(xlUp).Row - 1)
Application.ScreenUpdating = False
With Sheets.Add
.Range("a1").Resize(UBound(tbl, 1)) = tbl
With CreateObject("vbscript.regexp")
.Pattern = "(\D+)(\d+)"
For i = 1 To UBound(tbl, 1)
If .test(tbl(i, 1)) Then
tbl(i, 1) = Left(.Replace(tbl(i, 1), "$1"), 1) & Format(.Replace(tbl(i, 1), "$2"), "00000")
End If
Next i
End With
.Range("b1").Resize(UBound(tbl, 1)) = tbl
.Range("a1").Resize(UBound(tbl, 1), 2).Sort key1:=.Range("b1"), order1:=xlAscending, _
key2:=.Range("a1"), order2:=xlAscending
tbl = .Range("a1").Resize(UBound(tbl, 1))
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Range("b2").Resize(UBound(tbl, 1)) = tbl
Application.ScreenUpdating = True
End Sub
↓（追加）
ボケ防止作品（弥太郎）
ichinoseさん、弥太郎さん ありがとうございました。 私には絶対作れないコードです。。 本とインターネットだけではなかなか難しいですね。 (hai)
こんばんわ。作っていただいたコードで質問なのですが、
Ｇ列とＨ列を合体させる前に、処理を追加したいのですがうまく動きません。。
追加したい処理は下記です。
Sheets("sheet1").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "ダミー"
Rows("1:1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("sheet1").AutoFilter.Sort.SortFields.Add Key:= _
Range("A2:A32"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("sheet1").AutoFilter.Sort.SortFields.Add Key:= _
Range("F2:F32"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder _
:="A*,C*,B*", DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("sheet1").AutoFilter.Sort.SortFields.Add Key:= _
Range("G2:G32"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("sheet1").AutoFilter.Sort.SortFields.Add Key:= _
Range("H2:H32"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
'==================================================================
Option Explicit
Option Compare Text 'これも必須です
Sub samp()
Dim rng As Range
Set rng = Range("g2", Cells(Rows.Count, "g").End(xlUp))
With rng
If .Row > 1 Then
With .Offset(0, 1)
.Formula = "=except_alpha(rc[-1])"
.Value = .Value
End With
.Value = Evaluate("=if(" & .Address & "="""","""",SUBSTITUTE(" & _
.Address & "," & .Offset(0, 1).Address & ",""""))")
MsgBox "Ｇ列とＨ列をアルファベットとそれ以外に分けました。 確認してください"
↑↓この間に処理を入れたいです。
.Value = Evaluate("=" & .Address & "&" & .Offset(0, 1).Address)
MsgBox "Ｇ列とＨ列を合体させました"
End If
End With
End Sub
'====================================================================
Function except_alpha(mydata As Variant) As String
Dim chkstr As String
Dim g0 As Long
except_alpha = ""
chkstr = mydata
For g0 = 1 To Len(chkstr)
If Mid(chkstr, g0, 1) Like "[!a-z]" Then
except_alpha = except_alpha & Mid(chkstr, g0, 1)
End If
Next
End Function
(hai)
できました。。 失礼しました。 またお願いいたします。 (hai)
Option Explicit Sub test() Const INPUT_RANGE As String = "G2:G10" Const OUTPUT_RANGE_STR As String = "H" Const OUTPUT_RANGE_NUM As String = "I" Dim c As Variant Dim i As Long, ans As Long
For Each c In Range(INPUT_RANGE)
For i = 1 To Len(c.Value)
ans = Val(Mid(c.Value, i, 9))
If ans Then
Range(OUTPUT_RANGE_NUM & c.Row).Value = ans
Exit For
End If
Range(OUTPUT_RANGE_STR & c.Row).Value = Mid(c.Value, 1, i)
Next i
Next c
End Sub
INPUT_RANGEは自分で指定します。
文字部分はH列、数値部分はI列に出力するので、実行し終わったら表内のどこかをクリックしておいて、メニューの[データ]-[並べ替え]より、最優先されるキー[H列]昇順、2番目に優先されるキー[I列]昇順で並べ替え。
G列も連動して並び替えされているので、不要となったH、I列は自分で削除～ という感じで考えてます。
（ramrun）ぬ～ん
解決後ですが、
A001 a0
なんてデータでは
A 001 a 0
と分けるように（つまり、アルファベットと数字文字列）したいなら
Function except_alpha(mydata As Variant) As String
Dim chkstr As String
Dim g0 As Long
except_alpha = "'" 'ここを訂正
chkstr = mydata
For g0 = 1 To Len(chkstr)
If Mid(chkstr, g0, 1) Like "[!a-z]" Then
except_alpha = except_alpha & Mid(chkstr, g0, 1)
End If
Next
End Function
としたほうがよいですね！！
どっちかな？
ichinose
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.