| |
Lindy さん御親切にして頂き本当に有難うございます。いじりすぎて訳が分からなくなってしまいお願いしてしまいました。まだ触れたことのない構文もあり今後の課題として勉強します。最終的には二つのプログラムを一つにしようとしてますが
、最初に作ったプログラムは何所に何を書いても受け付けてくれません。プログラム上無理なのでしょうか。アドバイスをお願い頂けますか？本当に図々しくてすみません。
最初のプログラムはsheet1内の業者名を取得し業者数分のシートを作りタブに業者名をつけます。
Private Sub CommandButton1_Click()
Dim ws_list As Worksheet
Dim ws_add As Worksheet
Dim theName As String '会社名の保存用
Dim i As Integer
Dim startRow As Integer 'コピー範囲の先頭行の位置
Dim endRow As Integer 'コピー範囲の最終行の位置
Sheets("Sheet1").Activate
Range("C2").Select 'データを会社名順にソートしておく
Range("A2:J3000").Sort Key1:=Range("C2"),Order1:=xlAscending,Header:= _
xlGuess, OrderCustom:=1, chCase:=False,Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Set ws_list = Worksheets("Sheet1")
'最初の会社名でシートを作成する
startRow = 2
theName = ws_list.Cells(2, 3)
Set ws_add = Worksheets.Add
ws_add.Name = theName
For i = 2 To 1000
If ws_list.Cells(i, 3) <> theName Then
'会社名が変わったときの処理
'旧会社名のコピー処理
endRow = i - 1
ws_list.Select
ws_list.Range(Cells(startRow, 1), (Cells(endRow, 10))).Copy
ws_add.Paste
'新会社名のシート作成処理
theName = ws_list.Cells(i, 3)
If theName <> "" Then
Set ws_add = Worksheets.Add
ws_add.Name = theName
End If
'新会社名の開始位置を保存
startRow = i
End If
Next
Set ws_add = Nothing
Set ws_list = Nothing
End Sub
長くてすみません。
|
|
かずお
- 07/7/3(火) 17:45 -
