Results of 1 - 1 of about 37680 for IF (0.007 sec.)
- [[20070122064354]]
- #score: 1591
- @digest: b22a736ae122161afa7cf581a56855a5
- @id: 28059
- @mdate: 2007-03-04T00:56:21Z
- @size: 24838
- @type: text/plain
- #keywords: densya (116290), boxy (62213), 車:" (61991), 電車 (40672), 方" (27830), 帯番 (18166), tbl (11297), 午後 (10683), isempty (10306), 午前 (10238), 弥太 (10035), lrow (8817), resize (6556), 携帯 (6527), 性別 (6520), cells (5910), key1 (4344), integer (4324), 太郎 (4274), 両方 (4028), ubound (3874), colorindex (3183), sort (3031), タオ (2842), 郎さ (2794), dic (2681), delete (2641), redim (2595), screenupdating (2426), sheets (2314), clear (2056), オプ (1954)
- 『分類と並び替え』（BOXY）
過去ログを調べましたが、似たようなものがありましたがアレンジ方法が よく分からないので、以下の条件についてそのやり方をご指導願います。 〔A〕 〔B〕 〔C〕 1 名前 電車 性別 2 AAA A 1 3 BBB B 2 職場のレクで旅行に行くのに電車の時間がAとBの2通りあります。 名前は職場在籍者全員の名簿で1が男性、2が女性です。 電車の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) 応用例として以下の3つのパターンにトライしました。 1.sheet1の表がA1:D3ではなく、B3:E5の場合 2.shhet2への抽出がA1:D3ではなく、C3:F5の場合 3.電車がAとBではなく、アとイの場合 時間だけが過ぎてしまって、1つもクリアできそうにありません。 基本的なVBAプログラミングが理解できていないためですが、 入門書としてのお奨めがあれば、紹介して下さい。 ---- Sheet1にはB3からD5にデータが（3列ですわなぁ?）入っとるとして、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個のデータを使って実際にマクロを走らせてみたのですが、 古いパソコン（8年前のものWin98、エクセル2000）では5分くらいかかってしまいました。 それまでは、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のレイアウトは、7行目が項目で8行目からデータ入って、 F:名前、G:電車、H:部署、I:携帯番号、J:性別になっています。(BOXY) ---- ほなら、かういう事でっか? Sheet2のC列E列1行目から抽出しとります。 （弥太郎） 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) どこの会社にもいますよね、文句と注文だけはしっかり言う人! レクの幹事は百方美人を求められます。本当にありがとうございました。 是非、電車だけでなくレク先のオプションにも使いたいので ご協力の程よろしくお願いします。 オプション1（午前）とオプション2（午後）があって、両方とも参加、 両方とも不参加（空欄）、1だけ、2だけの4つの選択肢の中で1を 選んだ人のグループと2を選んだ人のグループで各々名前をランダムに 並び替えてたい。後から気が変わった人のために、1と2のソート後の 最終行の次の行に追加ができるようにしたい。男女の色分けはやめます。 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 この2つの文は見つかりましたが > 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) ---- G列8行目から下の方向へ午前、午後、両方などと入力されとりまっか? （弥太郎） ---- 弥太郎さん ご指摘通り、sheet1がAとBのままになっていました。 午前、午後、両方と再入力したら、解決しました。 本当にありがとうございました。(BOXY) ---- 弥太郎さん、ヘルプです。 午前、午後、両方の3つの選択で、全員が「午前」もしくは「午後」を 選択するとエラーが発生することが判明しました。 全員が「両方」ならOKです。(BOXY) ---- On Error Resume Next With Sheets("Sheet2")'この行の上に↑を追加 Application.ScreenUpdating = True 'この行の下に↓を追加 On Error GoTo 0 で、全て上手くいくと思いまっせぇ。 （弥太郎） ---- 弥太郎さん、ありがとうございました。（BOXY） ---- 弥太郎さん、またしてもヘルプです。(BOXY) 実践モードに入って苦労しています。 なんどもやってみましたが、追加1()のマクロを使って、午前または 両方では午前のみ追加され、午後または両方で午後には追加されません。 ---- ＞弥太郎さん、またしてもヘルプです。(BOXY) だいたいVBA少しは解ってるのか? ＞どこの会社にもいますよね、文句と注文だけはしっかり言う人! あんただろ? 金払ってどっかに頼め。 ---- スミマセン・・・(BOXY) ---- 最近秘匿性をええことに、暴言を吐く輩が目立ちまんなぁ。些か憤りをおぼえますわ。 BOXYさん、HNも書けない連中の暴言は無視しまひょ。 ところで、上の件、訂正しときましたんで、試してみてくらはい。 一ヶ所怪しいところがありました（汗 （弥太郎）... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/200701/20070122064354.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97037 documents and 608190 words.
訪問者：