[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『分類と並び替え』（BOXY）
過去ログを調べましたが、似たようなものがありましたがアレンジ方法が よく分からないので、以下の条件についてそのやり方をご指導願います。
〔A〕 〔B〕 〔C〕 1 名前 電車 性別 2 AAA A 1 3 BBB B 2
職場のレクで旅行に行くのに電車の時間がAとBの２通りあります。 名前は職場在籍者全員の名簿で１が男性、２が女性です。
電車のAかBか空欄（不参加）かを確認して入力した後、AとBの結果をそれぞれ別の シートに集計して、座席の割り振りのため名前をランダムに並び替えて、女性(2)の 名前だけ赤字で表示したい。 こんな条件なんですが･･･
関数で乱数を発生させると再計算の度に変化するので、マクロで書いてみました。
1)フィルタオプションの設定で電車=A,Bで別シートへ抽出
2)別シートのD列に乱数を発生
3)D列基準で並べ替え
4)C列が2の時文字色赤
4)不要列・行をクリア・削除
こんな感じでしょうか? (1/22 10:54部分修正)(Hatch)
Sub Macro1()
Dim lRow As Long, i As Integer
Dim c As Range
Dim sh(2) As Worksheet
Dim myCar(2) As String
Set sh(1) = Worksheets("Sheet2")
Set sh(2) = Worksheets("Sheet3")
myCar(1) = "A"
myCar(2) = "B"
For i = 1 To 2
With sh(i)
.Range("A:D").Clear
.Range("A2") = "=Sheet1!B2=""" & myCar(i) & """"
lRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet1").Range("A1:C" & lRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("A1:A2"), _
CopyToRange:=.Range("A4"), _
Unique:=False
lRow = .Range("A" & Rows.Count).End(xlUp).Row
Randomize
For Each c In .Range("D5:D" & lRow)
c.Value = Rnd()
Next c
.Range("A4:D" & lRow).Sort Key1:=.Range("D5"), Header:=xlYes
For Each c In .Range("A5:A" & lRow)
If c.Offset(0, 2).Value = 2 Then
c.Font.ColorIndex = 3
End If
Next c
.Range("D:D").Clear
.Range("1:3").Delete
End With
Next i
End Sub
Hatchさん、返事が遅くなりました。ありがとうございます。 もうひとつ教えて下さい。 連絡先を忘れていたので、B列に携帯番号を追加したい のですが、A：名前、B:携帯番号、C：電車、D:性別という構成に変更したら、 どうなりますか？
こんな感じになります。(Hatch)
Sub Macro1()
Dim lRow As Long, i As Integer
Dim c As Range
Dim sh(2) As Worksheet
Dim myCar(2) As String
Set sh(1) = Worksheets("Sheet2")
Set sh(2) = Worksheets("Sheet3")
myCar(1) = "A"
myCar(2) = "B"
For i = 1 To 2
With sh(i)
.Range("A:E").Clear
'---フィルタオプションの設定の条件式をA2に入力
.Range("A2") = "=Sheet1!C2=""" & myCar(i) & """"
lRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'---フィルタオプションの設定でAまたはBをSheet2(sh(1)）またはSheet3(sh(2))へ抽出
Sheets("Sheet1").Range("A1:D" & lRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("A1:A2"), _
CopyToRange:=.Range("A4"), _
Unique:=False
lRow = .Range("A" & Rows.Count).End(xlUp).Row
'---乱数をE列へ入力
Randomize
For Each c In .Range("E5:E" & lRow)
c.Value = Rnd()
Next c
'---E列を基準に並べ替え
.Range("A4:E" & lRow).Sort Key1:=.Range("E5"), Header:=xlYes
'---C列が2の時、文字色を赤に設定
For Each c In .Range("A5:A" & lRow)
If c.Offset(0, 3).Value = 2 Then
c.Font.ColorIndex = 3
End If
Next c
'---E列をクリア、1〜3行目を削除
.Range("E:E").Clear
.Range("1:3").Delete
End With
Next i
End Sub
Hatchさん、ありがとうございました。（BOXY) 申し訳ありませんが、マクロと1)〜5)について解説してもらえませんか？ 1)フィルタオプションの設定で電車=A,Bで別シートへ抽出 2)別シートのD列に乱数を発生 3)D列基準で並べ替え 4)C列が2の時文字色赤 5)不要列・行をクリア・削除
上記マクロのコード内にそれぞれの説明を追記しておきます。(Hatch)
Hatchさん、ありがとうございます。（BOXY) よく出てくるRangeの使い方について以下のマクロを例にもう少し詳しく 説明して頂けませんか？馴染みがないので、応用が効きません。 お手数ばかりかけますが、よろしくお願いします。
'---フィルタオプションの設定でAまたはBをSheet2(sh(1)）またはSheet3(sh(2))へ抽出
Sheets("Sheet1").Range("A1:D" & lRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("A1:A2"), _
CopyToRange:=.Range("A4"), _
Unique:=False
lRow = .Range("A" & Rows.Count).End(xlUp).Row
最初のlRowはSheet1の最終行、この部分はsh(i)が指定してあるので、sh(1)=Sheet2の時を書きます。 Sheet1のA1〜D列最終行のセル範囲へAdvancedFilterをかけます。 Action:=xlFilterCopyはリスト範囲とは他の場所に抽出データをコピーします。 CriteriaRange:検索条件範囲を指定しています。 Sheet2のA1:A2を指定しています。なお、A1は未使用、A2へは上の方で条件式を入力しています。 CopyToRange：抽出した行のコピー先のセル範囲を指定しています。 Sheet2のA4をコピー先に指定しています。 Unique=True=Falseは重複するレコードも含めて、検索条件に一致するレコードがすべて抽出されます。
lRow = .Range("A" & Rows.Count).End(xlUp).Row
ここでは、Sheet2の最終行(抽出データの最終行)をlRowに代入しています。
lRowは前にも使用していますが、ここで値が書き換えられています。
本当は変数名をlRow2などとして区別した方がいいのかもしれませんが、面倒でしたので流用しています。
以上でよろしいでしょうか？ (Hatch)
Hatchさん、いつもいつもありがとうございます。（BOXY) 自分でも問題を考えて、応用できるように頑張ってみます。 今後ともよろしくお願いします。
Hatchさん、昨日の解説から自分なりに応用（展開）を考えていますが 上手くいきません。（BOXY)
応用例として以下の３つのパターンにトライしました｡ 1.sheet1の表がA1:D3ではなく、B3:E5の場合 2.shhet2への抽出がA1:D3ではなく、C3:F5の場合 3.電車がAとBではなく、アとイの場合 時間だけが過ぎてしまって、１つもクリアできそうにありません。
基本的なＶＢＡプログラミングが理解できていないためですが、 入門書としてのお奨めがあれば、紹介して下さい。
Sheet1にはB3からD5にデータが（３列ですわなぁ？）入っとるとして、Sheet2のC列E
列に拾うマクロですワ。
試してみてくらはい。
（弥太郎）
'----------------------------
Option Explicit
Sub boxy()
Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
Dim w As Integer, tbl, x, t
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")
tbl = .Range("b2").Resize(.Range("b" & Rows.Count).End(xlUp).Row, 3)
End With
ReDim densya(1 To 2)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If Not dic.exists(tbl(i, 2)) Then
y = y + 1
densya(y) = tbl(i, 2)
dic(tbl(i, 2)) = Empty
If y = 2 Then Exit For
End If
End If
Next i
ReDim x(1 To UBound(tbl, 1), 1 To 3)
ReDim t(1 To UBound(tbl, 1), 1 To 3)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = densya(1) Then
m = m + 1
x(m, 1) = tbl(i, 1)
x(m, 2) = tbl(i, 3)
x(m, 3) = Int(Rnd * 10000)
Else
w = w + 1
t(w, 1) = tbl(i, 1)
t(w, 2) = tbl(i, 3)
t(w, 3) = Int(Rnd * 10000)
End If
End If
Next i
With Sheets("sheet2")
.Cells.Clear
.Cells.Font.ColorIndex = 0
.Cells(2, 3).Resize(m, 3) = x
.Cells(2, 7).Resize(w, 3) = t
.Cells(2, 3).Resize(m, 3).Sort key1:=.Cells(2, 5)
.Cells(2, 7).Resize(w, 3).Sort key1:=.Cells(2, 9)
s = IIf(m > w, m, w)
For i = 2 To s + 1
If .Cells(i, 4) = 2 Then .Cells(i, 3).Font.ColorIndex = 3
If .Cells(i, 8) = 2 Then .Cells(i, 7).Font.ColorIndex = 3
Next i
.Cells(1, 8).Resize(s + 1, 2).Delete: .Cells(1, 4).Resize(s + 1, 2).Delete
.Cells(1, 3) = densya(1): .Cells(1, 5) = densya(2)
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
弥太郎さん ありがとうございました。（BOXY）
この過去ログを参考に100個のデータを使って実際にマクロを走らせてみたのですが、 古いパソコン（８年前のものWin98、ｴｸｾﾙ2000）では５分くらいかかってしまいました。 それまでは、WinXPとｴｸｾﾙ2003のため気にならなかったのですが。
特に 1)フィルタオプションの設定で電車=A,Bで別シートへ抽出 2)別シートのD列に乱数を発生 3)D列基準で並べ替え 4)C列が2の時文字色赤 5)不要列・行をクリア・削除 のうちの2)と3)に時間を取られてしまうようです。 処理時間が半減できるようなマクロに変更はできますか？ もしくは数式で同様なことができませんか？ 古いパソコンの所有者から「マクロが遅い」（当然？）と言われているので。 （BOXY）
試したわけでもないですが、弥太郎さんのデクチョナリでも遅かったのでしょうか。
（川野鮎太郎）
弥太郎さんのデクチョナリでは未だ確認できていません。 確認してみます。（BOXY)
あれっ、これって、ええアイディアが有っても試しても貰われへんっちゅう事でんなぁ（笑 なんとなく無駄足踏んだみたい・・・、メモメモ。（笑 （弥太郎）
弥太郎さん、ゴメンナサイ。(BOXY)
エラーが出てそこで止まってしまいました。
実行時エラー'1004'：
「アプリケーション定義またはオブジェクト定義のエラーです。」
With Sheets("sheet2")
.Cells.Clear
.Cells.Font.ColorIndex = 0
.Cells(2, 3).Resize(m, 3) = x
→ .Cells(2, 7).Resize(w, 3) = t
.Cells(2, 3).Resize(m, 3).Sort key1:=.Cells(2, 5)
.Cells(2, 7).Resize(w, 3).Sort key1:=.Cells(2, 9)
s = IIf(m > w, m, w)
For i = 2 To s + 1
Sheet1の構成がちゃいまんなぁ。 A B C D 1 名前 2 山田 太郎 あ 1 3 小宮 悦治 あ 1 4 斉藤 シマ子 い 2 5 野中 和郎 い 2 6 野村 英紀 あ 1 7 嵐 寛寿郎 い 1 8 斉藤 フキ あ 1 9 田中 絹子 い 2 10 田中 真紀子 あ 2 とこんな塩梅とちゃいますん？ （弥太郎）
弥太郎さん >A：名前、B:携帯番号、C：電車、D:性別という構成に変更したら･･･ で確認しました。 現状のsheet1のレイアウトは、７行目が項目で８行目からデータ入って、 F:名前、G:電車、H:部署、I:携帯番号、J:性別になっています。(BOXY)
ほなら、かういう事でっか？
Sheet2のC列E列１行目から抽出しとります。
（弥太郎）
Sub boxy2()
Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
Dim w As Integer, tbl, x, t
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")
tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
End With
ReDim densya(1 To 2)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If Not dic.exists(tbl(i, 2)) Then
y = y + 1
densya(y) = tbl(i, 2)
dic(tbl(i, 2)) = Empty
If y = 2 Then Exit For
End If
End If
Next i
ReDim x(1 To UBound(tbl, 1), 1 To 3)
ReDim t(1 To UBound(tbl, 1), 1 To 3)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = densya(1) Then
m = m + 1
x(m, 1) = tbl(i, 1)
x(m, 2) = tbl(i, 5)
x(m, 3) = Int(Rnd * 10000)
Else
w = w + 1
t(w, 1) = tbl(i, 1)
t(w, 2) = tbl(i, 5)
t(w, 3) = Int(Rnd * 10000)
End If
End If
Next i
With Sheets("sheet2")
.Cells.Clear
.Cells(2, 3).Resize(m, 3) = x
.Cells(2, 7).Resize(w, 3) = t
.Cells(2, 3).Resize(m, 3).Sort key1:=.Cells(2, 5)
.Cells(2, 7).Resize(w, 3).Sort key1:=.Cells(2, 9)
s = IIf(m > w, m, w)
For i = 2 To s + 1
If .Cells(i, 4) = 2 Then .Cells(i, 3).Font.ColorIndex = 3
If .Cells(i, 8) = 2 Then .Cells(i, 7).Font.ColorIndex = 3
Next i
.Cells(1, 8).Resize(s + 1, 2).Delete: .Cells(1, 4).Resize(s + 1, 2).Delete
.Cells(1, 3) = "電車:" & densya(1): .Cells(1, 5) = "電車:" & densya(2)
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
弥太郎さん ありがとうございます。
今日は時間がないので、検証は夜になります。（スミマセン） もうひとつ厄介な条件が追加になりました。
不参加（空欄）から参加に変更する人が出た場合（電車のア or イになる）、 既に並び替えまで完成しているsheet2（アの場合）またはsheet3（イの場合）の 最終行の次の行にsheet1のデータ（名前、部署、携帯番号、性別）を追加したい。
レクの幹事も大変です。よろしくお願いします。（BOXY)
レクと言うても年にそう何度も行きまへんやろ？、それで処理時間が遅い等とクレーム
を付けられるとはにわかに信じがたいですなぁ。
わたしゃてっきり旅行会社で使うマクロやと思うとりましたが・・・。
それはともかく、性別まで拾うのなら何で処理時間のかかる色を付けますのん？色付け
するなら性別欄は不要と思いますけどなぁ。
試してくらはい。前述したようにSheet2に拾い出します。
それと追加したデータの色付けまでは考えとりまへん。
（弥太郎）
'------------
Sub boxy2()
Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
Dim w As Integer, j As Integer, tbl, x, t
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")
tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
End With
ReDim densya(1 To 2)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If Not dic.exists(tbl(i, 2)) Then
y = y + 1
densya(y) = tbl(i, 2)
dic(tbl(i, 2)) = Empty
If y = 2 Then Exit For
End If
End If
Next i
ReDim x(1 To UBound(tbl, 1), 1 To 6)
ReDim t(1 To UBound(tbl, 1), 1 To 6)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = densya(1) Then
m = m + 1
For j = 1 To 6
If j = 6 Then
x(m, j) = Int(Rnd * 10000)
ElseIf j <> 2 Then
x(m, j) = tbl(i, j)
End If
Next j
Else
w = w + 1
For j = 1 To 6
If j = 6 Then
t(w, j) = Int(Rnd * 10000)
ElseIf j <> 2 Then
t(w, j) = tbl(i, j)
End If
Next j
End If
End If
Next i
With Sheets("sheet2")
.Cells.Clear
.Cells(2, 3).Resize(m, 6) = x
.Cells(2, 9).Resize(w, 6) = t
.Cells(2, 3).Resize(m, 6).Sort key1:=.Cells(2, 8)
.Cells(2, 9).Resize(w, 6).Sort key1:=.Cells(2, 14)
s = IIf(m > w, m, w)
For i = 2 To s + 1
If .Cells(i, 7) = 2 Then .Cells(i, 3).Font.ColorIndex = 3
If .Cells(i, 13) = 2 Then .Cells(i, 9).Font.ColorIndex = 3
Next i
.Cells(1, 14).Resize(s + 1).Delete: .Cells(1, 10).Resize(s + 1).Delete
.Cells(1, 8).Resize(s + 1).Delete: .Cells(1, 4).Resize(s + 1).Delete
.Cells(1, 3) = "電車:" & densya(1): .Cells(1, 7) = "電車:" & densya(2)
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
'-----------------------------
Sub 追加()
Dim dic As Object, mx_1 As Long, mx_2 As Long, mx As Long, i As Long
Dim m As Integer, w As Integer, x, t, tbl, data_1
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet2")
mx_1 = .Cells(Rows.Count, 3).End(xlUp).Row
mx_2 = .Cells(Rows.Count, 7).End(xlUp).Row
mx = IIf(mx_1 > mx_2, mx_1, mx_2)
tbl = .Cells(2, 3).Resize(mx - 1, 8)
data_1 = Split(.Cells(1, 3), ":")(1)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 1)) = Empty
If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 5)) = Empty
Next i
End With
With Sheets("sheet1")
tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
End With
ReDim x(1 To UBound(tbl, 1), 1 To 4)
ReDim t(1 To UBound(tbl, 1), 1 To 4)
For i = 1 To UBound(tbl, 1)
If Not dic.exists(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = data_1 Then
m = m + 1
x(m, 1) = tbl(i, 1)
x(m, 2) = tbl(i, 3)
x(m, 3) = tbl(i, 4)
x(m, 4) = tbl(i, 5)
Else
w = w + 1
t(w, 1) = tbl(i, 1)
t(w, 2) = tbl(i, 3)
t(w, 3) = tbl(i, 4)
t(w, 4) = tbl(i, 5)
End If
End If
Next i
With Sheets("sheet2")
If m > 0 Then
.Cells(mx_1 + 1, 3).Resize(m, 4) = x
End If
If w > 0 Then
.Cells(mx_2 + 1, 7).Resize(w, 4) = t
End If
End With
Set dic = Nothing
End Sub
不具合発見 しゅうせぇ 12:43
弥太郎さん 只々感激しています。速いし、綺麗だし・・・。(BOXY)
どこの会社にもいますよね、文句と注文だけはしっかり言う人！ レクの幹事は百方美人を求められます。本当にありがとうございました。
是非、電車だけでなくレク先のオプションにも使いたいので ご協力の程よろしくお願いします。
オプション１（午前）とオプション２（午後）があって、両方とも参加、 両方とも不参加（空欄）、１だけ、２だけの４つの選択肢の中で１を 選んだ人のグループと２を選んだ人のグループで各々名前をランダムに 並び替えてたい。後から気が変わった人のために、１と２のソート後の 最終行の次の行に追加ができるようにしたい。男女の色分けはやめます。
F:名前、G:オプション、H:部署、I:携帯番号、J:性別です。
今のマクロの一部をいじれば叶うと思いまっせぇ。
例えば
>.Cells(1, 3) = "電車:" & densya(1): .Cells(1, 7) = "電車:" & densya
は、.cells(1,3)="午前":.cells(1,7)="午後"にし、
最初のFor i〜Next iは不要でっしゃろから削除
> If Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = densya(1) Then
> if not isempty(tbl(i,2)) then
if tbl(i,2)="午前" or tbl(i,2)="両方"
else を end if で一旦切ってしもうて
if tbl(i,2)="午後" or tbl(i,2)="両方" then
みたいに書き換えればいけまっしゃろ？
（弥太郎）
弥太郎さん マクロのいじり方がわかりません。。(BOXY)
>.Cells(1, 3) = "電車:" & densya(1): .Cells(1, 7) = "電車:" & densya > If Not IsEmpty(tbl(i, 2)) Then この２つの文は見つかりましたが
> if not isempty(tbl(i,2)) then が見つかりません。
難儀な御方でんなぁ（笑
いちいち説明しとると長引くんで作り変えましたワ。
（弥太郎）
'-------------------
Sub boxy3()
Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
Dim w As Integer, j As Integer, tbl, x, t
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")
tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
End With
ReDim x(1 To UBound(tbl, 1), 1 To 6)
ReDim t(1 To UBound(tbl, 1), 1 To 6)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = "午前" Or tbl(i, 2) = "両方" Then
m = m + 1
For j = 1 To 6
If j = 6 Then
x(m, j) = Int(Rnd * 10000)
ElseIf j <> 2 Then
x(m, j) = tbl(i, j)
End If
Next j
End If
If tbl(i, 2) = "午後" Or tbl(i, 2) = "両方" Then
w = w + 1
For j = 1 To 6
If j = 6 Then
t(w, j) = Int(Rnd * 10000)
ElseIf j <> 2 Then
t(w, j) = tbl(i, j)
End If
Next j
End If
End If
Next i
With Sheets("sheet2")
.Cells.Clear
.Cells(2, 3).Resize(m, 6) = x
.Cells(2, 9).Resize(w, 6) = t
.Cells(2, 3).Resize(m, 6).Sort key1:=.Cells(2, 8)
.Cells(2, 9).Resize(w, 6).Sort key1:=.Cells(2, 14)
s = IIf(m > w, m, w)
.Cells(1, 14).Resize(s + 1).Delete: .Cells(1, 10).Resize(s + 1).Delete
.Cells(1, 8).Resize(s + 1).Delete: .Cells(1, 4).Resize(s + 1).Delete
.Cells(1, 3) = "午前": .Cells(1, 7) = "午後"
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
'----------------------------------
Sub 追加1()
Dim dic As Object, mx_1 As Long, mx_2 As Long, mx As Long, i As Long
Dim m As Integer, w As Integer, x, t, tbl
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet2")
mx_1 = .Cells(Rows.Count, 3).End(xlUp).Row
mx_2 = .Cells(Rows.Count, 7).End(xlUp).Row
mx = IIf(mx_1 > mx_2, mx_1, mx_2)
tbl = .Cells(2, 3).Resize(mx - 1, 8)
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 1)) = Empty
'If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 5)) = Empty
'↓に変更
If Not IsEmpty(tbl(i, 5)) Then dic(tbl(i, 5)) = Empty
Next i
End With
With Sheets("sheet1")
tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
End With
ReDim x(1 To UBound(tbl, 1), 1 To 4)
ReDim t(1 To UBound(tbl, 1), 1 To 4)
For i = 1 To UBound(tbl, 1)
If Not dic.exists(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then
If tbl(i, 2) = "午前" Or tbl(i, 2) = "両方" Then
m = m + 1
x(m, 1) = tbl(i, 1)
x(m, 2) = tbl(i, 3)
x(m, 3) = tbl(i, 4)
x(m, 4) = tbl(i, 5)
End If
If tbl(i, 2) = "午後" Or tbl(i, 2) = "両方" Then
w = w + 1
t(w, 1) = tbl(i, 1)
t(w, 2) = tbl(i, 3)
t(w, 3) = tbl(i, 4)
t(w, 4) = tbl(i, 5)
End If
End If
Next i
With Sheets("sheet2")
If m > 0 Then
.Cells(mx_1 + 1, 3).Resize(m, 4) = x
End If
If w > 0 Then
.Cells(mx_2 + 1, 7).Resize(w, 4) = t
End If
End With
Set dic = Nothing
End Sub
弥太郎さん また難儀掛けます。(BOXY)
boxy3を実行したら、エラーが出てそこで止まってしまいました。
実行時エラー'1004'：
「アプリケーション定義またはオブジェクト定義のエラーです。」
With Sheets("sheet2")
.Cells.Clear
→ .Cells(2, 3).Resize(m, 6) = x
.Cells(2, 9).Resize(w, 6) = t
.Cells(2, 3).Resize(m, 6).Sort key1:=.Cells(2, 8)
.Cells(2, 9).Resize(w, 6).Sort key1:=.Cells(2, 14)
s = IIf(m > w, m, w)
Ｇ列８行目から下の方向へ午前、午後、両方などと入力されとりまっか？ （弥太郎）
弥太郎さん
ご指摘通り、sheet1がAとBのままになっていました。 午前、午後、両方と再入力したら、解決しました。 本当にありがとうございました。(BOXY)
弥太郎さん、ヘルプです。
午前、午後、両方の３つの選択で、全員が「午前」もしくは「午後」を 選択するとエラーが発生することが判明しました。 全員が「両方」ならＯＫです。(BOXY)
On Error Resume Next
With Sheets("Sheet2")'この行の上に↑を追加
Application.ScreenUpdating = True 'この行の下に↓を追加 On Error GoTo 0
で、全て上手くいくと思いまっせぇ。
（弥太郎）
弥太郎さん、ありがとうございました。（BOXY）
弥太郎さん、またしてもヘルプです。(BOXY)
実践モードに入って苦労しています。 なんどもやってみましたが、追加1()のマクロを使って、午前または 両方では午前のみ追加され、午後または両方で午後には追加されません。
＞弥太郎さん、またしてもヘルプです。(BOXY)
だいたいVBA少しは解ってるのか？
＞どこの会社にもいますよね、文句と注文だけはしっかり言う人！
あんただろ？
金払ってどっかに頼め。
スミマセン･･･(BOXY)
最近秘匿性をええことに、暴言を吐く輩が目立ちまんなぁ。些か憤りをおぼえますわ。 BOXYさん、HNも書けない連中の暴言は無視しまひょ。 ところで、上の件、訂正しときましたんで、試してみてくらはい。 一ヶ所怪しいところがありました（汗 （弥太郎）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.