文字列の最後を変化させたい

質問

業務でマクロを使うことになり、ご教示お願い致します。

（例）
実行前　→実行後
C列　　　　 C列
001　　　　　001
003　　　　　001-1
002　　　　　001-2
005　　　　　002
001　　　　　002-2
001　　　　　003
002　　　　　005

同じ文字が複数ある場合、2個目以降には”-1”、”-2”と区別し、並べ替えを実行。
（データはA列～BI列まで入っていますので、C列が動いた場合、連動させる形で…。）

ActiveWorkbook.Worksheets(BaseSheet).Activate
p = HeaderPos + 1

For i = (HeaderPos + 1) To SearchNum
CelValue = Range(Inbound & i).Value

For m = 0 To SearchNum
If KindType(m) = CelValue Then
KindCount(m) = KindCount(m) + 1
Range(Inbound & i).Value = KindType(m) + CStr(KindCount(m))
Exit For
ElseIf KindType(m) = "" Then
KindType(m) = CelValue
KindCount(m) = KindCount(m) + 1
Range(Inbound & i).Value = KindType(m) + CStr(KindCount(m))
Exit For
End If
Next

If CelValue = "" Then
Exit For
End If
Next

イメージはこんな感じなのですが、お分かりになる方よろしくお願いいたします。

回答No.6

kkkkkm · ベストアンサー

> 「実行時エラー1004　アプリケーション定義またはオブジェクト定義のエラーです」
> というエラーが出てきました。

コードの中のsheet1を正しい名前に変更しましたでしょうか。
コードを表示した画面の左側のペインで表示されているツリー上で

Sheet1(シート)

となっているシートの場合、コードでは With Sheets("シート")にしてください。通常の画面の下のタブに表示されているシート名になります。

> 現在A1には見出しが入っているので、A1を除いて並び替えは可能でしょうか？

Sub example3()

Dim BRow As Long

With Sheets("シート")
.Activate
BRow = .Range("A" & Rows.Count).End(xlUp).Row - 1
.Range("A2:BI" & BRow).Sort Key1:=.Range("A2"), order1:=xlAscending
.Range("XX2").Formula = "=A2 & (IF(COUNTIF(OFFSET($A$2,0,0,ROW(A1),1),A2)-1=0,"""", -(COUNTIF(OFFSET($A$2,0,0,ROW(A1),1),A2)-1)))"
.Range("XX2").Copy
.Range("XX2").Resize(BRow, 1).PasteSpecial Paste:=xlPasteFormulas
.Range("A2:A" & BRow).Value = .Range("XX2:XX" & BRow).Value
.Range("XX2").Resize(BRow, 1).ClearContents
.Range("A1").Select
End With

End Sub

お礼

解決いたしました。

何度もありがとうございました！m(_ _)m

補足

何度もありがとうございましたm(_ _)m

動くようになりました。
またこちらに質問した時には、よろしくお願い致します。

回答No.5

kkkkkm

No4の補足です。

ふと思ったのですがシートの保護とかはしていないですよね。

あと、並び替えが文字列の並び替えになるので連番が10を超えたときに
xxxx-1
xxxx-10
xxxx-2
のような順になってしまいます。
先に並び替えておくと上記のようにはなりませんので、並び替えと最終行を求める部分を最初に移動してください。以下のように .Activateの下に現在のコードの中にある該当の2行を移動してください。

With Sheets("sheet1")
.Activate
BRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:BI" & BRow).Sort Key1:=.Range("A1"), order1:=xlAscending

補足

お世話になっております。
度々のご回答、本当に有難うございます。

前回のエラーは出なくなりましたが、
「実行時エラー1004　アプリケーション定義またはオブジェクト定義のエラーです」
というエラーが出てきました。
デバッグをすると、
.Range("XX1").Formula = "=A1 & (IF(COUNTIF(OFFSET($A$1,0,0,ROW(A1),1),A1)-1=0,"""", -(COUNTIF(OFFSET($A$1,0,0,ROW(A1),1),A1)-1)))"
の所で反転しております。

ちなみにシートの保護等は一切かけていない状態です。
また、小出しの情報となってしまっていて申し訳ないのですが、
現在A1には見出しが入っているので、A1を除いて並び替えは可能でしょうか？
いろいろとお手数をおかけして申し訳ございませんm(_ _；)m

回答No.4

kkkkkm

> 試しに簡単に作ったファイルでは上手く動いてくれたのですが、
> 実際のファイルに入れると、下記のエラーが出てしまいます。

ちょっと原因がつかみかねますので、以下のコードで試してみてください。すべてのRange指定をsheet1(実際のシート名)のRangeとして指定するようにしてみました。sheet1は実際のシート名に変更してください。

Sub example2()

Dim BRow As Long

With Sheets("sheet1")
.Activate
.Range("XX1").Formula = "=A1 & (IF(COUNTIF(OFFSET($A$1,0,0,ROW(A1),1),A1)-1=0,"""", -(COUNTIF(OFFSET($A$1,0,0,ROW(A1),1),A1)-1)))"
.Range("XX1").Copy
BRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("XX1").Resize(BRow, 1).PasteSpecial Paste:=xlPasteFormulas
.Range("A1:A" & BRow).Value = .Range("XX1:XX" & BRow).Value
.Range("XX1").Resize(BRow, 1).ClearContents
.Range("A1:BI" & BRow).Sort Key1:=.Range("A1"), order1:=xlAscending
.Range("A1").Select
End With

End Sub

また、エラーが出たときのメッセージにデバッグボタンがあると思いますので、それをクリックしてコードのどこでエラーなのか(エラーのところで黄色反転してます)確認してみてください。

デバッグボタンがない場合、コードを表示した画面でF8キーを押してステップ実行してみてエラーの出る箇所を確認してみてください。

回答No.3

kkkkkm

> (2)番が上手く動かない理由かとおもうのですが、再度ご教示頂けませんでしょうか？
> よろしくお願いいたします

文字数を変化させてテストしてみましたが異常はなかったので列の指定の問題だと思います、元のコードはC列にデータがある前提でのコードですのでA列だと以下のようになります。
データはセルA1から始まっていてA列には最後まで必要なデータが並んでいるという前提です。

Sub example()

Dim BRow As Long

Range("XX1").Formula = "=A1 & (IF(COUNTIF(OFFSET($A$1,0,0,ROW(A1),1),A1)-1=0,"""", -(COUNTIF(OFFSET($A$1,0,0,ROW(A1),1),A1)-1)))"
'元の文字列の後ろに連番を追加したデータをXX列に作るためにセルXX1に数式を入れています。
Range("XX1").Copy
BRow = Range("A" & Rows.Count).End(xlUp).Row
'A列の最下行から上向きに調べていきデータのあるセルの最終行を求めています。
Range("XX1").Resize(BRow, 1).PasteSpecial Paste:=xlPasteFormulas
'セルXX1の式を1行目からさきほど求めた最終行まで貼り付けしています。これで同一文字列に連番が振られたデータがXX列に出来上がります。
Range("A1:A" & BRow).Value = Range("XX1:XX" & BRow).Value
'XX列のデータをA列に一気に代入しています。
Range("XX1").Resize(BRow, 1).ClearContents
'XX列の内容が不要なのでクリアしています。
Range("A1:BI" & BRow).Sort Key1:=Range("A1"), order1:=xlAscending
Range("A1").Select

End Sub

補足

再度のご回答ありがとうございます。
試しに簡単に作ったファイルでは上手く動いてくれたのですが、
実際のファイルに入れると、下記のエラーが出てしまいます。

「実行時エラー1004　'Range'メソッドは失敗しました:'Global'オブジェクト」

処理したいシートをアクティブになるよう１文を入れてみてもエラーは変わりませんでした。
他の理由でしょうか・・・？
何度も申し訳ございませんm(_ _)m

回答No.2

kkkkkm

もしエクセルのマクロでの話でしたら以下のような方法もあります。エクセルでなければ無視してください。

Sub example()

Dim BRow As Long

Range("XX1").Formula = "=C1 & (IF(COUNTIF(OFFSET($C$1,0,0,ROW(A1),1),C1)-1=0,"""",-(COUNTIF(OFFSET($C$1,0,0,ROW(A1),1),C1)-1)))"
Range("XX1").Copy
BRow = Range("C" & Rows.Count).End(xlUp).Row
Range("XX1").Resize(BRow, 1).PasteSpecial
Range("C1:C" & BRow).Value = Range("XX1:XX" & BRow).Value
Range("XX1").Resize(BRow, 1).ClearContents
Range("A1:BI" & BRow).Sort Key1:=Range("C1"), order1:=xlAscending
Range("A1").Select

End Sub

補足

ご回答ありがとうございます。
まさにエクセルでの質問でした。状況説明が色々至らずすみませんでした。
教えて頂いたコードをコピペさせて頂いたのですが、上手く動いて貰えない状況です。

最初の質問を少し補足させて頂いても良いでしょうか？
(1)C列　→　正しくはA列
(2)A列は文字列で、文字数は10～15文字程で字数がバラバラです。
　A54953-58R320のような感じです。

(2)番が上手く動かない理由かとおもうのですが、再度ご教示頂けませんでしょうか？
よろしくお願いいたします。

回答No.1

山田 太郎（@f_a_007）

Step1、最初に全体を昇順に並べる。
Step2、同じ番号が続く時は""、-1、-2、-3を末尾に付加する。

で目的は達成できると思います。

PS、REM文は書かれたが良いと思います。

お礼

ご回答ありがとございました。
並べ替えをまず入れました。
STEP2が難しいですね…。REM文、ちょっと調べてきますm(_ _)m