- 締切済み
配列に日付データを確保したい
ソースがエラーを起こしていて原因がわからず困っています。ご教授ください。 インデックスが有効範囲にありませんと出るのが、 kDate1 = Application.WorksheetFunction.Min(hDate1) です。 確保データシートの列行双方の項目名を拾い、該当するデータを進捗表で調べ該当を配列に入れるというもので（あとでループ処理追記）、配列にデータは日付です。 （文字数削減のためDimおかしいですが無視してください） Sub ssDate() Dim gRange As Range Dim sDate, fDate As Date Dim gKinou, gStep1, sStep1, sStep2 As String Dim sKinou, sRecord, a, i, k, m, rr, rr2 As Integer Dim kDate1～kDate6, hDate1()～ hDate6() As Variant Worksheets("確保データ").Select Cells(4, 5).Select 'テスト用 '冒頭処理 'Application.ScreenUpdating = False '画面描画停止 '全体設定 i = 9 '進捗表検索開始行 m = 7 '段階記載列 k = 0 '配列添 sKinou = 179'進捗表上機能名確定列 rr = 11 'K列 日付取得基準列 rr2 = 20 'T列日付取得基準列 '段階の設定 Set gRange = Selection gKinou = Cells(gRange.Row, 3).Value gStep1 = Cells(1, gRange.Column).Value '段階 Worksheets("進捗表").Select sRecord = Cells(i, 7).End(xlDown).Row '条件に該当するデータを配列で取得 For Each a In Range(Cells(i, m), Cells(sRecord, m)) '参照先設定 sStep1 = Cells(i, sKinou).Value sStep2 = Cells(i, 7).Value If gKinou = sStep1 And gStep1 = sStep2 Then ReDim hDate1(k) hDate1(k) = Cells(i, rr).Value '開始予定 hDate2(k) = Cells(i, rr + 1).Value '開始実績 hDate3(k) = Cells(i, rr + 2).Value '終了予定 hDate4(k) = Cells(i, rr + 3).Value '終了実績 If gStep1 = "見学" Or gStep1 = "会議" Then hDate5(k) = Cells(i, rr2).Value '見学 hDate6(k) = Cells(i, rr2 + 1).Value '会議 End If k = k + 1 End If Next MsgBox hDate1(0) '最小最大判定 kDate1 = Application.WorksheetFunction.Min(hDate1) '開始予定 ＜＜ここでエラー kDate2 = Application.WorksheetFunction.Min(hDate2) '開始実績 kDate3 = Application.WorksheetFunction.Max(hDate3) '終了予定 kDate4 = Application.WorksheetFunction.Max(hDate4) '終了実績 If gStep1 = "見学" Or gStep1 = "会議" Then kDate5 = Application.WorksheetFunction.Max(hDate5) '見学 kDate6 = Application.WorksheetFunction.Max(hDate6) '会議 End If MsgBox "開始予定：" & kDate1 & vbCrLf & "開始実績：" & kDate2 & vbCrLf _ & "終了予定：" & kDate3 & vbCrLf & "終了実績：" & kDate4 & vbCrLf _ & "内容：" & gKinou & vbCrLf & "段階：" & gStep1 Exit Sub End Sub
- riririsu22
- お礼率42% (15/35)
- Visual Basic
- 回答数3
- ありがとう数0
- みんなの回答 （3）
- 専門家の回答
みんなの回答
- imogasi
- ベストアンサー率27% (4737/17068)
既に出ているご回答の、VBAの基礎的なことは当然もっと前に勉強することだが、 質問のコードのしたいことを十分見てないが（質問にはデータ例を挙げて、したいことを文章で説明して質問すべきだ）そもそもエクセルでセルの値のために、配列など使う必要が無いのではないですか。 シートのセルの構成が配列的なんだから。だからCells(i,ｊ）が使えるのだし。 コード行数が半分ぐらいでこの質問の処理は出来るのではないかと思う。 プログラムで配列を使いたくなったら、一以呼吸して、適したロジックを考えること。
関連するQ&A
- 連続データのVBAの質問
お世話になります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Not Intersect(Target, Range("C1,B9:B39")) Is Nothing And Target.Count = 1 Then Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True ElseIf Not Intersect(Target, Range("R8:R38")) Is Nothing Then Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End If End Sub これはセルC１に年月を表記させ、そのC1セルの年月を変更した場合B９～B３９のセルが自動で連続データの数字を記入し、B9～B39のどこかのセルを空白にすると、そのセル以降も空白になります。 そしてR8～R38は、指定範囲のセルに数字を入力したら、そのセル以降の指定した範囲のセルに同じ数字を自動入力するVBAです。 そこで質問ですが、質問した現在は２０１３年１２月ですが、日本時間の現在の年月以前の年月（今で言うと２０１３年１１月以前）をC1に記入した場合はB9～B39の連続データの数字が切り替わらない様にするには、どうすれば宜しいでしょうか？
- ベストアンサー
- Excel（エクセル）
- ２つのVBAを組み合わせる方法
お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？
- ベストアンサー
- Excel（エクセル）
- VBA 請求データ一覧からの複数の処理
先週 kkkkkmさんに質問をさせて頂きまして、 いろいろご指導を頂いたものです。 続編の様な形になってしまいますが、 抽出するデータの環境設定を変更致しました。 ご質問させて頂く内容は前回とほとんど変更がないのですが、 あらためて下記に記載させて頂きます。 <Worksheet1のデータ> Ｊ列～AM列までが課税金額 「J,K,L」「M,N,O」・・・「AK,AL,AM」と3列1組（コード・費目・金額） 1組の行もあれば、複数組の行もあり。 AN列～BB列までが非課税金額 課税金額と同じく3列1組 1組の行もあれば、複数組の行もあり。 「BC」=消費税、「ＢＤ」=合計金額 ※AN列の前に不規則な空白セルあり BC列の前に不規則な空白セルあり 文章で上手く説明出来ているか自信がありませんので、 エクスポートした元データ Worksheet1と、 vbaを用いて作成した Worksheet3 をご参考に添付致します。 Worksheet1の2行目がWorksheet3の2行目に対応しています。 3行目、4行目も同様です。 不規則な空白が原因でしょうか・・・。 M列、O列は問題ないのですが、 金額が合わなかったり、N列に金額を引いてこないのです。 実行しているコードは下記になります。 Dim i As Long, j As Long, k As Long Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet Dim mTotal(4) As Long Dim LastRow As Long Dim List(4) As Variant Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") Set Ws3 = Sheets("請求書ひな形") List(1) = Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)).Value List(2) = Ws2.Range(Ws2.Cells(1, "B"), Ws2.Cells(Rows.Count, "B").End(xlUp)).Value List(3) = Ws2.Range(Ws2.Cells(1, "C"), Ws2.Cells(Rows.Count, "C").End(xlUp)).Value List(4) = Ws2.Range(Ws2.Cells(1, "D"), Ws2.Cells(Rows.Count, "D").End(xlUp)).Value LastRow = UBound(List(1)) For i = 2 To 4 If LastRow < UBound(List(i)) Then LastRow = UBound(List(i)) End If Next For i = 2 To Ws1.Cells(Rows.Count, "J").End(xlUp).Row mTotal(1) = 0 mTotal(2) = 0 mTotal(3) = 0 mTotal(4) = 0 For j = Columns("J").Column To Columns("BB").Column Step 3 For k = 2 To LastRow If UBound(List(1)) >= k Then If Ws1.Cells(i, j).Value = List(1)(k, 1) Then mTotal(1) = mTotal(1) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(2)) >= k Then If Ws1.Cells(i, j).Value = List(2)(k, 1) Then mTotal(2) = mTotal(2) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(3)) >= k Then If Ws1.Cells(i, j).Value = List(3)(k, 1) Then mTotal(3) = mTotal(3) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(4)) >= k Then If Ws1.Cells(i, j).Value = List(4)(k, 1) Then mTotal(4) = mTotal(4) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If Next Next Ws3.Cells(i, "J").Value = mTotal(1) Ws3.Cells(i, "K").Value = mTotal(2) Ws3.Cells(i, "L").Value = mTotal(3) Ws3.Cells(i, "N").Value = mTotal(4) Ws3.Cells(i, "M").Value = Ws1.Cells(i, "BC").Value Ws3.Cells(i, "O").Value = Ws1.Cells(i, "BD").Value Next Set Ws1 = Nothing Set Ws2 = Nothing Set Ws3 = Nothing End Sub 本当に何度も申し訳ございません。 お時間がある時に見て頂けると有り難いです。 どうぞ宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
- EXCEL VBAの配列でわかりません。
こんなコードがあるのですが、最後の他のシート（作業中シート）に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ～？？わからな～い？？おしえてくださーい！！ Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub
- ベストアンサー
- オフィス系ソフト
- vbaプログラミングについて教えてください。
vba初心者です。下記のようにプログラミングしましたがもっといいプログラムの仕方はないでしょうか。ちょっとごちゃごちゃしていて見にくいです。どなかたお力をお貸しください。 Private Sub データUPDATE輸入_Click() ActiveSheet.Unprotect Dim Line As String Dim Maxrow As String Sheets("Invoice").Select Line = 5 Do Until Cells(Line, 7).Value = "" On Error Resume Next 'A列の空欄をコピーして埋める If Cells(5, 1).Value = "" Then Cells(Line, 1).Value = "" ElseIf Cells(Line, 1).Value = "" Then Cells(Line, 1).Value = Cells(Line - 1, 1).Value End If 'B列の空欄をコピーして埋める If Cells(5, 2).Value = "" Then Cells(Line, 2).Value = "" ElseIf Cells(Line, 2).Value = "" Then Cells(Line, 2).Value = Cells(Line - 1, 2).Value End If 'C列の空欄をコピーして埋める If Cells(5, 3).Value = "" Then Cells(Line, 3).Value = "" ElseIf Cells(Line, 3).Value = "" Then Cells(Line, 3).Value = Cells(Line - 1, 3).Value End If 'D列の空欄をコピーして埋める If Cells(5, 4).Value = "" Then Cells(Line, 4).Value = "" ElseIf Cells(Line, 4).Value = "" Then Cells(Line, 4).Value = Cells(Line - 1, 4).Value End If 'E列の文字を「輸入シート」から検索しF列に貼り付ける If Cells(Line, 5).Value = "" Then Cells(Line, 5).Value = Cells(Line - 1, 5).Value End If Cells(Line, 6).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 2, 0) 'E列を検索しデータが存在しない場合はF列に「データがありません」を表記 If Cells(Line, 6).Value = "" Then Cells(Line, 6).Value = "データがありません" GoTo コピー貼り付け End If コピー貼り付け: If Cells(Line, 6).Value = "データがありません" Then Cells(Line, 5).Copy 'コピーする Maxrow = Worksheets("輸入Parts").Range("A1").End(xlDown).Row + 1 Worksheets("輸入Parts").Range("A" & Maxrow).PasteSpecial Paste:=xlPasteValues '値を貼り付け End If 'H列の空欄をコピーして埋める If Cells(5, 12).Value = "" Then Cells(Line, 12).Value = "" ElseIf Cells(Line, 12).Value = "" Then Cells(Line, 12).Value = Cells(Line - 1, 12).Value End If 'E列の文字を「輸入シート」から検索しZ列に貼り付ける Cells(Line, 26).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 3, 0) 'E列を検索しデータが存在しない場合はZ列に「データがありません」を表記 If Cells(Line, 26).Value = "" Then Cells(Line, 26).Value = "データがありません" End If 'AD列の空欄をコピーして埋める If Cells(5, 30).Value = "" Then Cells(Line, 30).Value = "" ElseIf Cells(Line, 30).Value = "" Then Cells(Line, 30).Value = Cells(Line - 1, 30).Value End If 'E列の文字を「輸入シート」から検索しAM列に貼り付ける Cells(Line, 39).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 18, 0) 'E列を検索しデータが存在しない場合はAM列に「データがありません」を表記 If Cells(Line, 39).Value = "" Then Cells(Line, 39).Value = "データがありません" End If '「Unit price」の計算・円建と外貨建が合わさったインボイスの場合の合計金額 If Cells(Line, 14).Value = "" Then Cells(Line, 13).Value = Cells(Line, 17).Value * Cells(Line, 33).Value / Cells(Line, 7).Value Else Cells(Line, 17).Value = Application.WorksheetFunction.RoundDown(Cells(Line, 14).Value * Cells(Line, 16), 0) Cells(Line, 15).Value = Cells(Line, 16).Value * Cells(Line, 33).Value / Cells(Line, 7).Value End If 'T.Invoice Priceの計算 Cells(Line, 23).Value = Application.WorksheetFunction.Sum(Cells(Line, 17), Cells(Line, 18), Cells(Line, 19), Cells(Line, 20), Cells(Line, 21), Cells(Line, 22)) 'VLOOKUP関数が終わり、エラーが発生したら止まる On Error GoTo 0 '次の行に移り最後の行まで検索 Line = Line + 1 Loop End Sub
- 締切済み
- Visual Basic
- VBAエクセル空白セル0の入力
C列が空白となるまで、F列・・・L列の空白セルに0を代入する。 という処理を行いたく以下コードで実行をして ファイル種類をCSVにて、保存した後名前の変更で拡張子をTXTにすると データ入力された列の以降がカンマの羅列が「,,,,,,,,(改行)」の繰り返しで表示されてしまいます。 (CSV保存の後、視覚的に空白部分を行選択して削除するとなくなります。) どうすれば、このカンマが表示されなくなるでしょうか。 うまく説明できてないですが、アドバイス御願いします。 Dim i As Long i = 3 Do Until Cells(i, 3).Value = "" If Cells(i, 6).Value = "" Then Cells(i, 6).Value = "0" End If If Cells(i, 7).Value = "" Then Cells(i, 7).Value = "0" End If If Cells(i, 8).Value = "" Then Cells(i, 8).Value = "0" End If If Cells(i, 9).Value = "" Then Cells(i, 9).Value = "0" End If If Cells(i, 10).Value = "" Then Cells(i, 10).Value = "0" End If If Cells(i, 11).Value = "" Then Cells(i, 11).Value = "0" End If If Cells(i, 12).Value = "" Then Cells(i, 12).Value = "0" End If i = i + 1 Loop
- 締切済み
- Visual Basic
- vba スケジュール更新マクロ研究中（長文です）
いつもお世話になります。 私の会社では、スケジュール管理するにあたり、1日を3つに分けています。 つまり、「午前」「午後」「夜間」「午前午後」「午後夜間」「全日」の6種になります。 只今私は、スケジュールが更新されたときに、上書きして変更点をメッセージボックスで返すマクロを考えています。 （趣味の範囲ですので締め切りはないのですが、なんせVBA始めて1ヶ月目なもんですから四苦八苦してます＞＜） そこで、とりあえず下記のような「更新前のスケジュール区分を検知してメッセージで返す」ところまで出来ました。 （もう少しスッキリできないものかと思っております。） ここに「更新版と見比べて変更し、メッセージで返す」という働きを足していこうと思っています。 が、別々にコードが書けても、それを合体させようとなると、どうやったらいいのか皆目見当が付きません。 難解に思われるのは、結合セルと入力済みデータの扱いです。 例えば、とある1日に対して、「午前」「午後」「夜間」と別々の予定が入ってたとします。 予定に変更が出て「夜間」が「全日」になってしまったとします。 コードに「生き残っているのは夜間だ」という判断をさせることは出来ませんよね？ （というのも、区分が変更された場合、文字列が一致しているとは限らないのです。） 対話型にして、チェックボックスみたいな形で選択させるのがいいのでしょうか？ オーバースペックで耳から煙が出そうです・・・ とりあえず下記がコードです。 "strage1"を古いスケジュール、"strage2"を更新版としています。 つたない記述ですが、ヒントをご教授くださいませ。 ------------------------------------ Sub 何を書き換えたかMsgBox2() Dim i As Integer, j As Integer Dim myMsg As String Dim myold As Worksheet, mynew As Worksheet Set myold = Sheets("strage1") Set mynew = Sheets("strage2") j = 5 For j = j To 35 i = 6 For i = i To 8 If IsEmpty(myold.Cells(j, i)) And Not IsEmpty(mynew.Cells(j, i)) Then myMsg = myMsg & mynew.Cells(j, i) & "が追加になりました" & vbCrLf ElseIf Not IsEmpty(myold.Cells(j, i)) And IsEmpty(mynew.Cells(j, i)) Then myMsg = myMsg & myold.Cells(j, i) & "がキャンセルになりました" & vbCrLf ElseIf myold.Cells(j, i) <> mynew.Cells(j, i) Then myMsg = myMsg & myold.Cells(j, i).Value & "から" & mynew.Cells(j, i) & "に変更しました" & vbCrLf End If myold.Cells(j, i).Value = mynew.Cells(j, i) Next Next MsgBox myMsg End Sub --------------------------------------------- Sub 区分識別3() Dim i As Integer Dim myMsg As String i = 5 For i = i To 35 If Cells(i, 6) <> "" Then If Cells(i, 6).MergeArea.Count = 3 Then myMsg = myMsg & i - 4 & "日、全日枠の" & Cells(i, 6).Value & "です。" & vbCrLf ElseIf Cells(i, 6).MergeArea.Count = 2 Then myMsg = myMsg & i - 4 & "日、午前午後枠の" & Cells(i, 6).Value & "です。" & vbCrLf Else myMsg = myMsg & i - 4 & "日、午前枠の" & Cells(i, 6).Value & "です。" & vbCrLf End If End If If Cells(i, 7) <> "" Then If Cells(i, 7).MergeArea.Count = 2 Then myMsg = myMsg & i - 4 & "日、午後夜間枠の" & Cells(i, 7).Value & "です。" & vbCrLf Else myMsg = myMsg & i - 4 & "日、午後枠の" & Cells(i, 7).Value & "です。" & vbCrLf End If End If If Cells(i, 8) <> "" Then myMsg = myMsg & i - 4 & "日、夜間枠の" & Cells(i, 8).Value & "です。" & vbCrLf End If Next MsgBox myMsg End Sub ------------------------------------------------------- 以上です。 よろしくお願いいたします。
- 締切済み
- Visual Basic
- 日付が同じなら削除
すみません、誰か教えて頂けませんでしょうか。 A列に日付と時間が記入されているのですが、日付だけを比較して 同じなら削除したいのですが、誰かご教授頂けませんでしょうか。 A列 2013/8/14 8:00 2013/8/14 8:15 2013/8/14 10:00 2013/8/15 8:00 2013/8/16 8:00 2013/8/17 8:00 2013/8/17 20:00 2013/8/18 8:00 2013/8/18 9:00 A列 2013/8/14 8:00 2013/8/15 8:00 2013/8/16 8:00 2013/8/17 8:00 2013/8/18 8:00 Sub 削除 () Dim r As Long Dim y As Long r = Cells(Rows.Count,1).End(xlUp).Row For y = r To 1 Step -1 If Cells(y,1).Value = Cells(y,1).Offset(1,0) Then 'この比較がわかりません。 Cells(y,1).Offset(1,0).Delete(xlUp) End If Next y End Sub すみませんが、宜しくお願いします。
- ベストアンサー
- オフィス系ソフト
- VBAで複数の行のナンバーを取得し、その行の列の値を参照して値を入れる
下記のことをしたいのですが、調べてもわかりません。 どなたか教えてください。 よろしくお願いします。 内容： エクセルシートのA列の値が11である行ナンバーを取得（複数ある可能性があります）する。 その行のE列（5列目）の値と他のテーブルの値を参照して所定の値をA列の値が11である行のE列（5列目）に返す。 以下のVBAを書いてみましたがうまくいきません。 ----------------------------------------------------------------- Dim ROWCOUNT As Integer Dim row_array() As Variant Dim i As Integer '全行数を取得 ROWCOUNT=Worksheets("sheet1").Range("A1",Range("A65536").End(xlUp)).Count For i = 1 To ROWCOUNT If Cells(i, 1).Value = 11 Then Cells(i,1).Offset(0,5).Value=WorksheetFunction.VLookup(Cells(i, 1).Offset(0, 5).Value, Worksheets("sheet2").Range("A1:H1786"), 3, False) End If Next I
- ベストアンサー
- その他（プログラミング・開発）
- マクロを簡潔にしたいので教えてください。
Sub 記入() Dim testno As String Dim testrow As Long Dim basedata(1 To 10) As String Dim weight(1 To 16) As Double Sheets("sh3").Select '(1) testno = Range("B23").Value 'No. Sheets("sh1").Select For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(testno) Then testrow = i Exit For End If Next i If i = 5 Then MsgBox ("?") End End If For i = 1 To 10 basedata(i) = Cells(testrow, i + 1) Next i '(2) Sheets("sh2").Select For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(testno) Then testrow = i Exit For End If Next i If i = 5 Then MsgBox ("?") End End If For i = 1 To 6 weight(i) = Cells(testrow, i + 1) Next i For i = 7 To 12 weight(i) = Cells(testrow, i + 2) Next i weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6)) weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6)) weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12)) weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12)) Sheets("sheet3").Select Cells(3, 1) = testno For i = 1 To 10 Cells(3, i + 1) = basedata(i) Next i For i = 1 To 16 Cells(3, i + 11) = weight(i) Next i Sheets("sh3").Select Erase basedata Erase weight '(1) testno = Range("B24").Value 'No. Sheets("sh1").Select For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(testno) Then testrow = i Exit For End If Next i If i = 5 Then MsgBox ("?") End End If For i = 1 To 10 basedata(i) = Cells(testrow, i + 1) Next i '(2) Sheets("sh2").Select For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(testno) Then testrow = i Exit For End If Next i If i = 5 Then MsgBox ("?") End End If For i = 1 To 6 weight(i) = Cells(testrow, i + 1) Next i For i = 7 To 12 weight(i) = Cells(testrow, i + 2) Next i weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6)) weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6)) weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12)) weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12)) Sheets("sh3").Select Cells(4, 1) = testno For i = 1 To 10 Cells(4, i + 1) = basedata(i) Next i For i = 1 To 16 Cells(4, i + 11) = weight(i) Next i Sheets("sh3").Select Erase basedata Erase weight この間同様文12個あり '(1) testno = Range("B37").Value If testno = "" Then End End If Sheets("sh1").Select For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(testno) Then testrow = i Exit For End If Next i If i = 5 Then MsgBox ("?") End End If For i = 1 To 10 basedata(i) = Cells(testrow, i + 1) Next i '(2) Sheets("sh2").Select For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(testno) Then testrow = i Exit For End If Next i If i = 5 Then MsgBox ("?") End End If For i = 1 To 6 weight(i) = Cells(testrow, i + 1) Next i For i = 7 To 12 weight(i) = Cells(testrow, i + 2) Next i weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6)) weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6)) weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12)) weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12)) Sheets("sh3").Select Cells(17, 1) = testno For i = 1 To 10 Cells(17, i + 1) = basedata(i) Next i For i = 1 To 16 Cells(17, i + 11) = weight(i) Next i End Sub
- ベストアンサー
- その他MS Office製品
