- 締切済み
accessからexcelへ出力時。。。
３つのクエリを一つのエクセルシートへ出力しようとしているのですが、 3つ目が張り付きません。なんでなんでしょうか？どなたか教えてください。 Dim dbs As Database Dim rst1 As Recordset Dim rst2 As Recordset Dim rst3 As Recordset Dim intRow As Integer Dim intCell As Integer Dim xlsx As Object Set dbs = CurrentDb Set rst1 = dbs.OpenRecordset("クエリA") Set rst2 = dbs.OpenRecordset("クエリB") Set rst3 = dbs.OpenRecordset("クエリC") Set xlsx = CreateObject("Excel.Application") 'Excelオブジェクトを生成 With xlsx .ScreenUpdating = False '画面の再描画を抑止 .Workbooks.Add '新しいブックを追加 '---"クエリA"---------------------------------------------------- intRow = 1 For intCell = 1 To rst1.Fields.Count .Cells(intRow, intCell).Value = rst1.Fields(intCell - 1).Name .Cells(intRow, intCell).Interior.ColorIndex = 15 Next intCell '各レコード出力 intRow = 2 Do Until rst1.EOF For intCell = 1 To rst1.Fields.Count .Cells(intRow, intCell).Value = rst1.Fields(intCell - 1) Next intCell intRow = intRow + 1 rst1.MoveNext Loop '集計Sum For intCell = 4 To rst1.Fields.Count .Cells(intRow + 1, intCell) = "=SUM(" & Cells(2, intCell).Address & ":" & Cells(intRow, intCell).Address & ")" Next intCell ・ ・2目のクエリはOK ・ ・ ’以下3つ目のクエリ Dim intRow3 As Integer Dim intCell3 As Integer intRow3 = intRow + 5 intCell3 = 5 For intCell3 = 5 To rst3.Fields.Count .Cells(intRow3, intCell3).Value = rst3.Fields(intCell3 - 1).Name .Cells(intRow3, intCell3).Interior.ColorIndex = 15 Next intCell3 '各レコード出力 intRow3 = intRow + 6 Do Until rst3.EOF For intCell3 = 5 To rst3.Fields.Count .Cells(intRow3, intCell3).Value = rst3.Fields(intCell3 - 1) Next intCell3 intRow3 = intRow3 + 1 rst3.MoveNext Loop '---- Dim rst3RC As Integer rst3RC = intRow + 5 + rst3.RecordCount '863 '集計Sum For intCell3 = 6 To rst3.Fields.Count - 1 .Cells(rst3RC, intCell3) = "=SUM(" & Cells(rst3RC - rst3.RecordCount, intCell3).Address & ":" & Cells(rst3RC - 1, intCell3).Address & ")" Next intCell3
- ruby-amor
- お礼率58% (10/17)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- Hayashi_Trek
- ベストアンサー率44% (366/818)
rst3 のフィールド数は何個でしょう？ フィールド数が５未満なら、For文の中は一度も実行されないことになります。
関連するQ&A
- VBAで行列を作る方法
次のようなプログラミングで１，０，－１の要素で作られる3×3行列を全通り調べています。 この場合３の９乗通り調べることができます。 これを4×4や５×５行列など数を大きくして調べたいのですが、このプログラムを配列を使うなどして 簡単にできる方法を教えてください。 よろしくおねがいします。 Sub test() Dim a As Integer '行 Dim b As Integer '列 Dim c As Integer, i As Integer, j As Integer, d As Integer, e As Integer Dim 内積 As Integer, step As Integer Dim f As Integer, g As Integer, h As Integer, l As Integer, m As Integer, n As Integer, k As Integer, x As Integer Dim sum As Integer, total As Integer Dim aa As Integer, aaa As Integer, aaaa As Integer, bb As Integer, bbb As Integer, bbbb As Integer a = 3 '行 b = 3 '列 c = 0 内積 = 0 con = 0 sum = 0 tatal = 0 aa = 0 aaa = 0 aaaa = 0 bb = 0 bbb = 0 bbbb = 0 x = 0 For n = 0 To 2 For m = 0 To 2 For l = 0 To 2 For k = 0 To 2 For h = 0 To 2 For g = 0 To 2 For f = 0 To 2 For e = 0 To 2 For d = 0 To 2 '要素がすべて１ For i = 1 To a For j = 1 To b Cells(i, j) = 1 Next j Next i If bbbb = 1 Then Cells(a - 2, b - 2) = 0 ElseIf bbbb = 2 Then Cells(a - 2, b - 2) = -1 End If If bbb = 1 Then Cells(a - 1, b - 2) = 0 ElseIf bbb = 2 Then Cells(a - 1, b - 2) = -1 End If If bb = 1 Then Cells(a, b - 2) = 0 ElseIf bb = 2 Then Cells(a, b - 2) = -1 End If If aaaa = 1 Then Cells(a - 2, b - 1) = 0 ElseIf aaaa = 2 Then Cells(a - 2, b - 1) = -1 End If If aaa = 1 Then Cells(a - 1, b - 1) = 0 ElseIf aaa = 2 Then Cells(a - 1, b - 1) = -1 End If If aa = 1 Then Cells(a, b - 1) = 0 ElseIf aa = 2 Then Cells(a, b - 1) = -1 End If If total = 1 Then Cells(a - 2, b) = 0 ElseIf total = 2 Then Cells(a - 2, b) = -1 End If If sum = 1 Then Cells(a - 1, b) = 0 ElseIf sum = 2 Then Cells(a - 1, b) = -1 End If If con = 1 Then Cells(a, b) = 0 ElseIf con = 2 Then Cells(a, b) = -1 End If con = con + 1 Next d con = 0 sum = sum + 1 Next e sum = 0 total = total + 1 Next f total = 0 aa = aa + 1 Next g aa= 0 aaa = aaa + 1 Next h aaa = 0 aaaa = aaaa + 1 Next k aaaa = 0 bb = bb + 1 Next l bb = 0 bbb = bbb + 1 Next m bbb = 0 bbbb = bbbb + 1 Next n End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルマクロ配列で変数は使えますか
エクセル2013です。 初めて配列を使います。 以下のように作成し思ったようにできました。 Sub 計算() '成功 Dim a As Integer Dim c As Integer Dim b(5) As Integer Dim 最終行 Dim 値列 値列 = 17 最終行 = Cells(Rows.Count, 1).End(xlUp).Row For 処理業 = 1 To 最終行 For a = 1 To 5 b(a - 1) = Cells(1, 値列) 値列 = 値列 + 1 Next 値列 = 17 For a = 1 To (22 - 値列) c = c + b(a - 1) Next Cells(処理業, 30) = c a = 0 c = 0 Next 処理業 End Sub ただ計算する列の範囲をインプットボックスで入力した値 にしたい為以下のように改造しました。 Dim b(対象列) As Integerでエラーになります 配列には変数は使用できないのでしょうか？ よろしくお願いします。 Sub 計算() '失敗 Dim a As Integer Dim c As Integer Dim b(対象列) As Integer’★ここでERRになる Dim 最終行 Dim 対象列 Dim 値列 対象列 = 22'インプットボックスで入力した値 値列 = 17 最終行 = Cells(Rows.Count, 1).End(xlUp).Row For 処理業 = 1 To 最終行 For a = 1 To (対象列 - 17) b(a - 1) = Cells(1, 値列) 値列 = 値列 + 1 Next 値列 = 17 For a = 1 To (22 - 値列) c = c + b(a - 1) Next Cells(処理業, 30) = c a = 0 c = 0 Next 処理業 End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルマクロで教えてください
マクロ初心者です。アドバイスをお願いします。以下のマクロですとB列の100行目までの塗りつぶしのセルのカウントは出来るのですが、シート上の全てをカウントしたいのです。１TO 100の100の部分をどう変更したら良いのか教えてください。 Sub セルの色数1() Dim I As Integer Dim Count As Integer Count = 0 For I = 1 To 100 If Cells(I, 2).Interior.ColorIndex <> xlNone Then Count = Count + 1 Next I Range("C1").Value = Count End Sub
- 締切済み
- その他(業務ソフトウェア)
- Excel VBAライフゲーム
ExcelのVBAでライフゲームを作りたいのですが、次のプログラムの途中以降がわかりません。 もしよろしければ、このつづきの簡単な実行できるVBAライフゲームを教えてください。 続きのプログラムを教えていただけたら幸いです。 Option Explicit Const ALIVE As Integer = 1 Const DEAD As Integer = 0 Const SIZE As Integer = 19 Const Tmax As Integer = 100 Dim C(SIZE, SIZE) As Integer Sub LifeGame() Dim InitRate As Single Dim T As Integer Dim N As Integer Dim Cnext(SIZE, SIZE) As Integer Dim I As Integer, J As Integer InitRate = -1 Do While InitRate < 0 Or 1 < InitRate Loop For I = 0 To SIZE For J = 0 To SIZE If Rnd() < InitRate Then C(I, J) = ALIVE Else C(I, J) = DEAD End If Next J Next I For T = 1 To Tmax For I = 0 To SIZE For J = 0 To SIZE If C(I, J) = ALIVE Then Cells(I + 1, J + 1).Value = "■" Else Cells(I + 1, J + 1).Vallue = "" End If Next J Next I For I = 0 To SIZE For J = 0 To SIZE N = Count(I, J) Next J Next I For I = 0 To SIZE For J = 0 To SIZE C(I, J) = Cnext(I, J) Next J Next I Next T End Sub Function Count(I As Integer, J As Integer) As Integer End Function
- ベストアンサー
- SE・インフラ・Webエンジニア
- エクセルマクロでEnd Subが見つからないとでる
Excelのマクロ記述についての質問です． 以下のマクロはエクセルにない関数「IMMULT」をあらかじめ定義するためのものです．（技術計算のHPより入手し，コピーして貼り付けたものです） これを実行すると「End Subがみつからない」と出てしまいます．End Subは記述しているのになぜでしょうか，どなたか解決策を教えて頂けませんか！ Sub 関数定義() Public Function IMMULT(a As Range, b As Range) As Variant Dim r1 As Integer, r2 As Integer, c1 As Integer, c2 As Integer, nn As Integer Dim r As Integer, c As Integer Dim cr As Integer, cc As Integer Dim n As Integer Dim mm() As Variant r1 = a.Rows.Count r2 = b.Rows.Count c1 = a.Columns.Count c2 = b.Columns.Count If (c1 = r2) Then nn = c1 Else Exit Function End If cr = r1 cc = c2 ReDim mm(1 To cr, 1 To cc) For r = 1 To cr For c = 1 To cc mm(r, c) = 0 For n = 1 To nn mm(r, c) = IMSUMa(mm(r, c), IMPRODUCTa(a.Cells(r, n), b.Cells(n, c))) Next Next Next IMMULT = mm End Sub
- ベストアンサー
- Excel（エクセル）
- Excelマクロ CSV出力
Private Sub cmd_csv_Click() Open "\\サーバ名\フォルダ名\あああ.csv" For Output Access Write As #1 With Sheets("データ") For intRow = 3 To .Range("a2").End(xlDown).Row Print #1, .Cells(intRow, 1) & "," & .Cells(intRow, 2) & "," & .Cells(intRow, 3) & "," & .Cells(intRow, 4) & "," & .Cells(intRow, 5) & "," & .Cells(intRow, 6) & "," & .Cells(intRow, 7) & "," & .Cells(intRow, 8) & "," & .Cells(intRow, 9) & "," & .Cells(intRow, 10) & "," & .Cells(intRow, 11) & "," & .Cells(intRow, 12) & "," & .Cells(intRow, 13) & "," & .Cells(intRow, 14) & "," & .Cells(intRow, 15) Next intRow End With Close #1 MsgBox "出力完了しました。 " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "出力ファイル：フォルダ名\あああ.csv" End Sub ------------------------------------------------------------- 上記のロジックで「データ」シートのA3からO列の最終行までをCSV出力しています。 このマクロにA列に値が入った行のみを出力する(A列が空白なら無視し次の行へ)というロジックを追加したいのですが、方法がわかる方いらっしゃいますか？ どなたか教えてくださいm(__)m！！
- ベストアンサー
- Visual Basic
- エクセルのマクロについて
お手数ですが誰か教えてください！ BのデーターをAに集計するマクロを作ったのですが 処理速度とっても遅いのです。 高速で処理する方法はありませんでしょうか？ 私が作ったマクロ Sub 集計() Dim Z As Integer Dim i As Integer Dim X As Integer For Z = 2 To 2000 For i = 2 To 2000 For X = 3 To 20 If Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) And Worksheets("A").cells(1, X) = Worksheets("B").cells(i, 14) Then Worksheets("A").cells(Z, X) = Worksheets("B").cells(i, 16) End If Next X Next i Next Z End Sub どこかが間違っている気がしますがマクロ初心者のため 先に進めません。 どうかご教授よろしくお願い致します。
- 締切済み
- Visual Basic
- シートAとシートBの得意先コードが一致したら、該当行をシートCにコピー
シートAとシートBの得意先コードが一致したら、該当行をシートCにコピーするVBAを組みたいのですが、上手く行きません。加えてシートＡの該当行は削除しておきたいです。 ＸＰでExcel2003を使用しています。 Const strMasSheet = "A" Const strMasSheet2 = "B" Const strSrhSheet = "C" Dim strSrhCode As Long 'シートAの得意先コード Dim strSrhCode2 As Long 'シートBの得意先コード Dim intRow As Long Dim intRow2 As Long Dim intCnt As Long Dim maxgyo As Long 'シートAの最終行 Dim maxgyo2 As Long 'シートBの最終行 Sub データを分ける() maxgyo = Sheets(strMasSheet).Cells(Rows.Count, 1).End(xlUp).Row 'シートAの最終行を取得 For intRow = 2 To maxgyo '2行から始めて最終行まで（1upで） strSrhCode = Sheets(strMasSheet).Cells(intRow, 2) '検索値 B列= 得意先ＣＤを取得 maxgyo2 = Sheets(strMasSheet2).Cells(Rows.Count, 1).End(xlUp).Row 'シートBの最終行を取得 For intRow2 = 2 To maxgyo '2行から始めて最終行まで（1upで） strSrhCode2 = Sheets(strMasSheet).Cells(intRow, 8) '検索値 H列 = 得意先ＣＤを取得 intCnt = 2 '2行から If strSrhCode = strSrhCode2 Then 'もし検索値と検索対象シートの得意先ＣＤが一致したら intCnt = intCnt + 1 With Sheets(strSrhSheet) .Cells(intCnt, 1) = Cells(intRow, 1) .Cells(intCnt, 2) = Cells(intRow, 2) .Cells(intCnt, 3) = Cells(intRow, 3) .Cells(intCnt, 4) = Cells(intRow, 4) .Cells(intCnt, 5) = Cells(intRow, 5) .Cells(intCnt, 6) = Cells(intRow, 6) .Cells(intCnt, 7) = Cells(intRow, 7) .Cells(intCnt, 8) = Cells(intRow, 8) .Cells(intCnt, 9) = Cells(intRow, 9) .Cells(intCnt, 10) = Cells(intRow, 10) .Cells(intCnt, 11) = Cells(intRow, 11) End With End If Next intRow2 Next intRow MsgBox "処理終了" End Sub 言葉足らずの所があればごめんなさい。 追記いたしますので、教えて下さい。 よろしくお願い致します。
- ベストアンサー
- その他MS Office製品
- アクセス2000VBA DAOをADOに書き換えてください
アクセス2000VBA DAOをADOに書き換えてください 下記プログラムをADOに書き換えてください。（DAT1、DAT2はモジュールにて定義してあります） Option Compare Database Dim DBS As Database Dim QDF As QueryDef Dim RST As DAO.Recordset Dim COUNT1 Private Sub Form_Load() On Error Resume Next DAT2 = [Forms]![伝票]![HAKKOU1] Set DBS = CurrentDb Set QDF = DBS.QueryDefs("発行") With QDF .Parameters("DAT1") = DAT2 ’もしかしたら DAT2 ではエラーがでるかもしれません。 Set RST = .OpenRecordset() ’正しい記述を教えてください .Close End With With RST COUNT1 = !指示書 .Close End With
- ベストアンサー
- オフィス系ソフト
- ACCESSからEXCELに出力する際、時間がかかる。
よろしくお願いします。 ACCESS VBA を使用して、既存のEXCELファイルにデータを出力しているのですが、すごく時間がかかってしまいます。件数が少ない時はそれほど気にならないのですが。時間短縮する方法を教えてください。 Sub S_ExportExcel_ADO() Dim CN As ADODB.Connection Dim rst As ADODB.Recordset Dim objExcel As Excel.Application Dim i As Integer Dim W_SQL As String On Error GoTo Err_S_ExportExcel_ADO Set objExcel = New Excel.Application objExcel.Workbooks.Open ("test.xls") objExcel.Worksheets("sheet1").Select Set CN = CurrentProject.Connection Set rst = New ADODB.Recordset W_SQL = "SELECT * FROM データ" rst.Open W_SQL, CN, adOpenKeyset, adLockReadOnly i = 1 Do Until rst.EOF objExcel.Cells(i, 4) = Trim("" & rst![データ１]) objExcel.Cells(i, 5) = Trim("" & rst![データ２]) objExcel.Cells(i, 6) = Trim("" & rst![データ３]) objExcel.Cells(i, 7) = Trim("" & rst![データ４]) objExcel.Cells(i, 9) = Trim("" & rst![データ５]) '＊＊＊省略＊＊＊ objExcel.Cells(i, 35) = Trim("" & rst![データ１５]) objExcel.Cells(i, 36) = Trim("" & rst![データ１６]) i = i + 1 rst.MoveNext Loop 'EXCEL保存 objExcel.ActiveWorkbook.Close objExcel.Quit rst.Close CN.Close Set rst = Nothing Set CN = Nothing Set objExcel = Nothing End Sub
- ベストアンサー
- その他（プログラミング・開発）
お礼
フィールドは４つでしたが、 ひとつづつ記述をし直して試していったところできました。 原因は分からないですが、どこかがちがっていたのかも。 ありがとうございました。