[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『列にある複数のデータセルからある一定の文字列が含まれたセルを別々のシートに纏めるて保存するマクロ』（まっこい）
初めての質問・投稿失礼致します。
きちんと要約出来ず、解り辛くて申し訳ありません。
並びに既に解決済みでしたら申し訳ありません。
質問なのですが、
例えばA列に
1○○@docomo
2○○@ezweb
3○○@softbank
と〜100くらいまで色々な文字列のデータがあったとします。
それを
@docomoと文字列が付くデータをシート2に
@ezwebと文字列が付くデータをシート3に
@softbankと文字列が付くデータをシート4に
と出来るマクロや方法は御座いませんでしょうか？
非常に初歩的な質問かも知れませんが、
ご教授やご助力を頂ける方いらっしゃいましたらぜひ、
コメントを宜しくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
できますけど、もう少し仕訳ルール明確にしていただけますか？ 提示いただいた例では３種類ですが、たとえばi.softbankやdisnyなどはそのキャリアに振り分けるのかどうか。 メールのドメインはそれこそ無数にあると思いますので、それらをすべて別シート、というのは いささか乱暴ではないですかね？ ３キャリア以外は「その他シート」に入れるなど明確に指示してください。
それから「たとえばA列」と言われれば、A列のみ対象にしたコードを書きますが、 後から実はB列も・・・など仕様変更は面倒ですので、セル番地は必ずご指定ください。
（稲葉） 2014/10/22(水) 21:11
せっかくご解答頂いていたのにご対応せずの不義理で申し訳ありません。
引き続きのご教授をお願いしたいと考えておりますので、どうぞ宜しくお願い致します。
【仕訳ルール】
・@docomo = シート1のA列
・@ezweb = シート2のA列
・@softbank = シート3のA列
・@i.softbank = シート4のA列
・vodafone.ne.jp = シート5のA列
以上の５つ以外はその他のシートに一纏め(A列)というカタチで処理をしたいです。
最初にご解答頂きました稲葉様を含め、ご教授頂ける方おりましたら
ぜひ、宜しくお願い申し上げます。
（まっこい） 2014/12/06(土) 18:18
各ドメインは「.ne.jp」まで記述されているという前提ですが以下でどうでしょう もし「.ne.jp」が記述されていないのであれば、"docomo.ne.jp"等 を変更してください また、シート名もこちらで適当に設定したので適宜変更してください Sub a()
Dim i As Long
Dim strDomain As String
Dim strAddress As String
For i = 1 To ws1.Range("A" & Rows.Count).End(xlUp).Row
strAddress = ThisWorkbook.Worksheets("メールアドレス").Cells(i, 1).Value
If 0 < InStr(strAddress, "vodafone.ne.jp") Then
strDomain = Mid(strAddress, InStr(strAddress, "@") + 3, Len(strAddress) - InStr(strAddress, "@"))
Else
strDomain = Mid(strAddress, InStr(strAddress, "@") + 1, Len(strAddress) - InStr(strAddress, "@"))
End If
Select Case strDomain
Case "docomo.ne.jp"
With ThisWorkbook.Worksheets("シート1")
.Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1).Value = strAddress
End With
Case "ezweb.ne.jp"
With ThisWorkbook.Worksheets("シート2")
.Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1).Value = strAddress
End With
Case "softbank.ne.jp"
With ThisWorkbook.Worksheets("シート3")
.Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1).Value = strAddress
End With
Case "i.softbank.ne.jp"
With ThisWorkbook.Worksheets("シート4")
.Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1).Value = strAddress
End With
Case "vodafone.ne.jp"
With ThisWorkbook.Worksheets("シート5")
.Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1).Value = strAddress
End With
Case Else
With ThisWorkbook.Worksheets("その他")
.Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1).Value = strAddress
End With
End Select
Next i
End Sub （hoge） 2014/12/08(月) 11:39
Sub test()
Dim i As Long
Dim j As Long
Dim iFlag As Long
Dim vw As Variant
Dim vA As Variant
Dim vS As Variant
Dim iC() As Long
vA = Array("docomo.", "ezweb.", "i.softbank.", "softbank.", ".vodafone.ne.jp")
vS = Array("docomo", "ezweb", "i", "softbank", "vodafone", "その他")
ReDim iC(UBound(vS))
For i = 0 To UBound(vS)
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = vS(i)
Next i
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
iFlag = 0
vw = Split(Cells(i, "A").Value, "@")
For j = 0 To UBound(vA)
If vw(1) Like "*" & vA(j) & "*" Then
iC(j) = iC(j) + 1
Sheets(vS(j)).Cells(iC(j), "A").Value = Cells(i, "A").Value
iFlag = j + 1
Exit For
End If
Next j
If iFlag = 0 Then
iC(j) = iC(j) + 1
Sheets(vS(j)).Cells(iC(j), "A").Value = Cells(i, "A").Value
End If
Next i
End Sub
（???） 2014/12/08(月) 12:34
気づくの遅くてすみません。 すでに出る幕なかった！ （稲葉） 2014/12/08(月) 15:36
※稲葉様も有難うございますm(_ _)m
（まっこい） 2014/12/08(月) 15:43
早速取り組んでみます！！！ 取り急ぎお礼のご連絡を申し上げますm(_ _)m
※稲葉様も有難うございますm(_ _)m
（まっこい） 2014/12/08(月) 15:48
加えてお伺いできればと存じますが、
マクロのブックと編集元のマクロを別々にしたい
場合はどこを編集すれば宜しいのでしょうか？
初心者質問で申し訳ありません。
ご教授頂ければ幸いです。
（まっこい） 2014/12/08(月) 17:12
変更したい場合、他ブックを開く処理の追加と、現在Sheetsオブジェクトを操作している箇所全部を、
開いたブックのシート指定に変更することになります。
とりあえず、まずはそのまま自ブック内のシートにバラすことで使い、別ブックへは
手作業でシートコピーしていただくのが一番簡単かと思います。
（現状、自シートを元データとして使うことで、上記のような問題が出ないコーディングになっている訳です）
（???） 2014/12/08(月) 17:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.