Excelのマクロを作ってもらえますか？

質問

こんにちは。
エクセルのマクロで、Sheet1に転々と
入力されているデータを
すべてA1の列へ統一して並べ替え(2)
同じデータの数を計算してB2へ記述する(3)などという
マクロができるなら作っていただけないでしょうか？
もし、数の入った行のみ残して削除までできれば最良なの
ですが(4)

(2)
AA-20
AA-20
AA-20
BB-30
CC-30
CC-30
CC-30

(3)
AA-20 　　3
AA-20
AA-20
BB-30 　　1
CC-30 　　3
CC-30
CC-30

(4)
AA-20 　　3
BB-30 　　1
CC-30 　　3

このようになのですが、
お時間のあるときで結構ですので宜しくお願いします。

回答No.2

BLUEPIXY · ベストアンサー

作ってみました。
シート１に点在して入力されている文字列の個数を数えて
シート２に書き出します。
並び替えはしていないので、その後並び替えて下さい。
Public Sub strCellCount()
Dim r As Range, x As Range
Dim d
Dim pos, str
Set d = CreateObject("Scripting.Dictionary")

Set r = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeConstants, xlTextValues)

For Each x In r
If d.Exists(x.Value) Then
d.Item(x.Value) = d.Item(x.Value) + 1
Else
d.Add x.Value, 1
End If
Next
Set r = Worksheets("Sheet2").Range("A1")
pos = 0
For Each str In d.keys
r.Offset(pos).Value = str
r.Offset(pos, 1).Value = d.Item(str)
pos = pos + 1
Next
End Sub

お礼

有難うございました！
できました！！完璧です！うれしいです！
本当に何でもできてしまうんだと感動してます。
少しでも理解できるように作っていただいたマクロを解読しながら大事に使わせていただきます。
また宜しくお願いします。

回答No.3

imogasi

Ｂ列以右のデータをＡ列の空きセルに突っ込み、ソートします。
そして件数を出します。
Sub test01()
i = 1
Dim cl As Range
For Each cl In Selection
If cl <> "" Then
While Cells(i, "A") <> ""
i = i + 1
Wend
Cells(i, "A") = cl
i = i + 1
End If
Next
MsgBox i - 1
Range(Cells(1, "A"), Cells(i - 1, "A")).Sort key1:=Range("a1"), order1:=xlAscending
'------
m = Cells(1, "A")
n = 1
k = 1
Cells(k, "C") = m
For j = 1 To i - 1
If Cells(j, "A") = m Then
n = n + 1
Else
Cells(k, "D") = n
n = 1
k = k + 1
m = Cells(j, "A")
Cells(k, "C") = m
End If
Next j
Cells(k, "D") = n
End Sub
Ｂ列以右のデータの有る範囲を多めに範囲指定して
実行してください。

お礼

有難うございました！
出来ました～いろいろな方法があるのですね。
データの履歴を残したい時などにとても便利です。
大事に使わせて頂きます。
また、宜しくお願いします。

回答No.1

bin-chan

題意が今一つわからないので、以下の操作を行って、結果をお知らせください。

１．メニューのツール＞マクロ＞新しいマクロの記録 とクリックする。
２．「マクロの記録」でＯＫを押す。
３．あなたの思っている動作を行う。（失敗しないよう、すべての手順をお願いしますよ）
４．メニューのツール＞マクロ＞記録終了 とクリックする。
５．メニューのツール＞マクロ＞編集 とクリックする。
６．[Sub Macro1]から[End Sub]までを範囲選択し、コピーする。
７．回答への補足に貼り付ける。

多分、行列入れ替えてコピーし、降順にコピーし、再び行列入れ替えてコピーでしょうね。

補足

ありがとうございます。
操作をしたマクロを貼り付けました。
SortはＣＡＤからデータを転送し貼り付けるため、
どの列のどの行にデータが入力されているか
決まっていないので、上部へつめる為だけのものです。
実際にはＮ列くらいまではSortさせています。
各列のデータを切り取ってＡの列の後尾へコピーし
COUNTIFを行うためのSORTです。
（ここまででも良いのです）

ＣＯＵＮＴＩＦ関数でデータの数を出し、
隣の列へ文字列としてコーピーしてデータの
入っていない行を削除しているものです。

ご確認宜しくお願いします。

' Macro1 Macro
' マクロ記録日 : 2004/11/23 ユーザー名 : moonhare
'

'
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Columns("B:B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Columns("C:C").Select
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Columns("D:D").Select
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Columns("E:E").Select
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Range("C1:C2").Select
Selection.Cut
Range("A4").Select
ActiveSheet.Paste
Range("D1:D2").Select
Selection.Cut
Range("A6").Select
ActiveSheet.Paste
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Range("B1").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
Range("B4").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
Columns("B:B").Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Range("2:3,5:7").Select
Range("A5").Activate
Selection.Delete Shift:=xlUp
Range("A1").Select
End Sub