- 締切済み
QエクセルVBARange3か所に合致する合計額2
お世話になります。 下記は質問内容の現在の出力マクロです Private Sub CommandButton32_Click() Unload Me Sheets("入力").Select Set dic1 = CreateObject("Scripting.Dictionary") Sheets("入力").Select Set dic2 = CreateObject("Scripting.Dictionary") Sheets("入力").Select Set dic3 = CreateObject("Scripting.Dictionary") v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 10) dic1(sName) = dic1(sName) + v(i, 12) Next v = Sheets("入力").Range("B2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 2) dic2(sName) = dic2(sName) + v(i, 12) Next v = Sheets("入力").Range("B2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 4) dic3(sName) = dic3(sName) + v(i, 12) Next Workbooks.Add With Sheets("sheet1").Range("B3").Resize(dic1.Count) .Resize(, 2).Value = Application.Transpose(Array(dic1.Keys(), dic1.Items())) End With With Sheets("sheet2").Range("B3").Resize(dic2.Count) .Resize(, 2).Value = Application.Transpose(Array(dic2.Keys(), dic2.Items())) End With With Sheets("sheet3").Range("B3").Resize(dic3.Count) .Resize(, 2).Value = Application.Transpose(Array(dic3.Keys(), dic3.Items())) End With End Sub 前回質問からCD等もろもろ手抜きで書いたため少し違っています。 伝わるか心配ですが書き込みますので宜しくお願いします。 例、B列の重複した会社名C列の重複した支店加入者名D列の重複した班名そしてG列には重複した変更可能な重複した商品があります。重複したものをまとめてそれぞれに合計を出してBooks.AddのSheet1(現在はSheet1~sheet3に出力)に出力したいのです。その他の列は自動で出るように関数が張り付けてありますが質問には関係ないと思いますので割愛します。 つたない質問で申し訳ありませんがわかる方がありましたら回答をお願いします。 尚、(現在はSheet1~sheet3に出力)これではsheet1~sheet3を行ったり来たりで効率が悪くて困っています。宜しくお願いします
- nebikitorikai
- お礼率93% (86/92)
- Visual Basic
- 回答数7
- ありがとう数7
- みんなの回答 (7)
- 専門家の回答
みんなの回答
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは 添付された画像のセル位置と、求める結果の表を提示してみて下さい。
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは 元のデータ範囲はA1:L5としてあります。 もし、A2:L6なら、 Set t = tsh.Range("A1").CurrentRegion.Resize(, 12) を Set t = tsh.Range("A2").CurrentRegion.Resize(, 12) とするか、 Set t = tsh.Range("A2:L6") として試して下さい。
お礼
有難うございます試してみましたがダメでした。
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは 結果例が有れば分かりやすいのですが、 Private Sub CommandButton32_Click() Dim wBK As Workbook Dim tsh As Worksheet Dim t As Range Dim i As Long Dim j As Long Dim v As Variant Dim s As String Dim k As String Unload Me Set tsh = ThisWorkbook.Worksheets("入力") Set t = tsh.Range("A1").CurrentRegion.Resize(, 12) k = t.Columns(12).Address(1, 1, 1, 1) Set wBK = Workbooks.Add v = Array(10, 2, 4) For i = 1 To 3 With wBK.Worksheets("Sheet1") j = i * 2 - 1 t.Columns(v(i - 1)).Cells(1, 1).Copy .Cells(1, j) t.Columns(v(i - 1)).AdvancedFilter xlFilterCopy, , .Cells(1, j), True s = t.Columns(v(i - 1)).Address(1, 1, 1, 1) With .Range(.Cells(2, j), .Cells(Rows.Count, j).End(xlUp)).Offset(, 1) .Formula = "=SUMIF(" & s & "," & _ wBK.Worksheets("Sheet1").Cells(2, j).Address(0, 1, 1, 1) & "," & k & ")" .Value = .Value End With .Cells(1, j).Offset(, 1) = t.Range("L1") End With Next End Sub こんな感じですか?
お礼
有難うございます。
補足
親切にお付き合い下さいまして本当に感謝しています。結果新規ブックのB2,D2,F2にそれぞれ0が付きます。先に私がアップしたdic1に1列追加して結果合計は出せないものでしょうか? v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 10) dic1(sName) = dic1(sName) + v(i, 12) Next 私には能力不足で考えが出ません、宜しくお願いします
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは Private Sub CommandButton32_Click() Dim wBK As Workbook Dim tsh As Worksheet Dim t As Range Dim i As Long Dim v As Variant Dim s As String Dim k As String Unload Me Set tsh = ThisWorkbook.Worksheets("入力") Set t = tsh.Range("A1").CurrentRegion.Resize(, 12) k = t.Columns(12).Address(1, 1, 1, 1) Set wBK = Workbooks.Add v = Array(10, 2, 4) For i = 1 To 3 With wBK.Worksheets("Sheet" & i) t.Columns(v(i - 1)).Cells(1, 1).Copy .Range("B3") t.Columns(v(i - 1)).AdvancedFilter xlFilterCopy, , .Range("B3"), True s = t.Columns(v(i - 1)).Address(1, 1, 1, 1) With .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1) .Formula = "=SUMIF(" & s & ",B4," & k & ")" .Value = .Value End With .Range("C3").Value = t.Range("L1") End With Next End Sub これで、どうでしょうか? Dictionaryでもループする部分は流用出来ると思います。
お礼
有難うございます。
補足
新規ブックSheet1,2,3にRange("C1")に0、Range("C2")に0、Range("C4")に0、Range("B3")にはセルのコピーされたものが張り付いています。私の希望は現在出力されているsheet1,2,3を1つのsheetに会社1の支店加入者名=合計額というようなマクロがほしいのですが.... 表現力不足でごめんなさい。宜しくお願いします
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは 2003じゃダメですね。 Dictionaryでまとめるのも出来ますけど、 また後で、フィルタオプション方式に書き換えてアップしますね。
お礼
有難うございます。
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは 済みません、Excelのバージョンはなんでしょうか?
お礼
有難うございます、慌て者でごめんなさい。
補足
あ!ごめんなさい!先に書いておくべきでした、2003です。2013の方はインデックスが違うのでまだ試していません。
- ushi2015
- ベストアンサー率51% (241/468)
こんにちは どこが非効率なのか良く分かりませんが、 Private Sub CommandButton32_Click() Dim wBK As Workbook Dim tsh As Worksheet Dim t As Range Dim i As Long Dim v As Variant Dim s As String Dim k As String Unload Me Set tsh = ThisWorkbook.Worksheets("入力") Set t = tsh.Range("D2").CurrentRegion.Resize(, 12) k = t.Columns(12).Address(1, 1, 1, 1) Set wBK = Workbooks.Add v = Array(10, 2, 4) For i = 1 To 3 With wBK.Worksheets("Sheet" & i) t.Columns(v(i - 1)).Copy .Range("B3") s = t.Columns(v(i - 1)).Address(1, 1, 1, 1) .Range("B3").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes With .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1) .Formula = "=SUMIF(" & s & ",B4," & k & ")" .Value = .Value End With .Range("C3").Value = t.Range("L1") End With Next End Sub とかでも、出来ますか?
お礼
ご回答ありがとうございます、早速試しましたがオブジェクトはこのプロバテイはサポートしていません。と この部分で.Range("B3").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYesエラーが出ました。宜しくお願いします
関連するQ&A
- マクロ ソートをしたいのですが、組み込めますか
マクロの説明 1.Sub Sample7()はsheet4の列をソートするマクロです。 (単独では、このマクロでソートできる) 2.Sub sample2()はsheet4のソート以外は完成しています。 やりたいこと Sub sample2()の中にsheet4の重複データを削除したもののソートのコードを組み込みたい。 但し、組み込むとしてSub Sample7()のコードでよいのか、初心者なのでよくわかりません。 なお、Sub sample2()のマクロは途中省いています。 Sub Sample7() Sheets("sheet4").Range("A1:A1135").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes End Sub Sub sample2() Dim data As Variant 'データコピー用の使いまわし配列 Dim dic As Object Dim i As Long Set dic = CreateObject("Scripting.Dictionary") 'Sheet4~5のA列をリセット Sheets("Sheet4").Range("A2:A" & Rows.Count).ClearContents Sheets("Sheet5").Range("C3:C" & Rows.Count).ClearContents ↓↓↓↓↓↓↓↓↓↓↓↓↓↓ 'Sheet4に重複していないデータを書き込み With Sheets("Sheet4") .Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(dic.Count).Value = Application.Transpose(dic.keys) 'Sheet4のC列をSheet5にコピー data = .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Sheets("Sheet5").Range("C3").Resize(UBound(data)).Value = data Set dic = Nothing End Sub
- ベストアンサー
- Excel(エクセル)
- エクセルVBAでTransposeの不思議
MS Officeのエクセル2000です。 下記Sub test01はRange("A1:I1")に文字列を入力し、一旦配列に取り込んでからワークシートに貼り付けるものです。 試験用のコードですので意味はありません。 このコードで255文字まではまったく問題はありません。 ところが、256文字以上の場合、横に貼り付けは問題ないのですが、 Transposeで縦に変換すると型が一致しません。(Error 13)となります。 どうしてでしょうか? 試行錯誤の結果、Sub test02のように一旦横に貼ったデータをコピーしてTransposeして貼り付けるのは大丈夫のようですので不思議でしょがありません。 またこの方法は列数256より要素が多い配列には使えないので解決策にはなりません。 ご教示くださいませ。 Sub test01() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A5").Resize(UBound(myAr, 2)).Value = Application.Transpose(myAr) '256文字の場合エラー End With End Sub Sub test02() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A3").Resize(, UBound(myAr, 2)).Copy .Range("A5").PasteSpecial Paste:=xlValues, Transpose:=True '256文字の場合もOK Application.CutCopyMode = False End With End Sub
- ベストアンサー
- その他MS Office製品
- マクロdictionaryオブジェクト書き換え
ここで教えていただいたマクロを シート1のF列を検索値として シート2のA列を検索しヒットしたら シート2の該当行のD列をシート1のAE列に転記。 データの2列目から行う。ヒットしない場合は 無 と転記。 と変更したくて記述を書き換えたらシート1が壊れてしまいました。 正しい記述を教えてください。 ↓教えていただいた書き換え前の正常動作する記述↓ Sub 検索() 'dictionaryオブジェクトを使用 'シート1のA列を検索値として 'シート2のA列を検索しヒットしたら 'シート2の該当行のE列をシート1のC列に転記 'データの2行目から行う。ヒットしない場合は無しと転記 Dim dic As Object Dim i As Long Dim v, w Dim t As Single t = Timer With Sheets("Sheet2") '返す値を指定E列 With .Range("E2", .Cells(.Rows.Count, 1).End(xlUp)) '検索する列指定 (1)=A列 v = .Columns(1).Value '返す値のある列指定 (5)=E列 w = .Columns(5).Value End With End With Set dic = CreateObject("scripting.dictionary") For i = 1 To UBound(v) dic(v(i, 1)) = i Next With Sheets("Sheet1") '検索値のある列指定 A列 With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)) v = .Value For i = 1 To UBound(v) If dic.exists(v(i, 1)) Then v(i, 1) = w(dic(v(i, 1)), 1) Else v(i, 1) = "無" End If Next '転記する列を指定 Offset(, 2)=検索値のA列より右2つ→C列 With .Offset(, 2) .ClearContents .Value = v End With End With End With Set dic = Nothing Debug.Print Timer - t End Sub ---- ↓書き換えておかしな動きになった物 ●の部分を変更しました↓ Sub 検索02() 'dictionaryオブジェクトを使用 'シート1のF列を検索値として 'シート2のA列を検索しヒットしたら 'シート2の該当行のD列をシート1のAE列に転記 'データの2行目から行う。ヒットしない場合は無しと転記 Dim dic As Object Dim i As Long Dim v, w Dim t As Single t = Timer With Sheets("Sheet2") '返す値を指定D列● With .Range("D2", .Cells(.Rows.Count, 1).End(xlUp)) '検索する列指定 (1)=A列 v = .Columns(1).Value '返す値のある列指定 (4)=D列● w = .Columns(4).Value End With End With Set dic = CreateObject("scripting.dictionary") For i = 1 To UBound(v) dic(v(i, 1)) = i Next With Sheets("Sheet1") '検索値のある列指定 F列● With .Range("F2", .Cells(.Rows.Count, 1).End(xlUp)) v = .Value For i = 1 To UBound(v) If dic.exists(v(i, 1)) Then v(i, 1) = w(dic(v(i, 1)), 1) Else v(i, 1) = "無" End If Next '転記する列を指定 'Offset(, 25)=検索値のA列より右25個→AE列● With .Offset(, 25) .ClearContents .Value = v End With End With End With Set dic = Nothing Debug.Print Timer - t End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBA どうしても動きません。
お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません(データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します)。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします!!!!!! Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。
- ベストアンサー
- Visual Basic
- エクセルVBA Range3か所に合致する合計額
お世話になります。エクセルRange("A")からRange("L") & LastRowまで入力してあります。 Range("B3")列以下には会社名Range("D3")列以下には班名Range("J3")列以下には品名がありRange("L3")列以下に合計額が入力されています。 この入力された中から(A,D,Jに合致する合計額)これをWorkBooks.Add sheets("sheet1").Range("A2")に出力したいのです.どなたか宜しくお願いします。
- 締切済み
- Visual Basic
- 再:(できる方)エクセルVBA印刷済を印刷しない
リストに追加された内容をチェックシートに差し込み印刷する運用を考えています。 リストは定期的に追加され、前回リストに追加した内容は今回の印刷は印刷しないように したいです。 例)10:00 1~3を入力/1~3を印刷済 11:00 4~6を入力/4~6を印刷する ※10:00の1~3hは再度印刷しないようにする ■したいこと 一度印刷した内容もリスト上にあれば、再度印刷されるので、印刷済フラグをたてて、 次回印刷は印刷済フラグをチェックし、再度印刷されないようにしたい ※現マクロは下記にしるしています。(モジュール1) ※画像に関連する2つのシートを添付しています 上部:データ入力 下部:問合せ回答一覧 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sub 流し込み印刷() Sheets("データ入力").Select Dim mylastRow As Long '最終行を格納する変数 Dim myLastCol As Integer '最終列を格納する変数 Dim myLastCell As String '最終セルを設定する変数 With ActiveSheet.UsedRange '対象はアクティブシートの使用中のセル '最終行の行番号 mylastRow = .Rows(.Rows.Count).Row '最終列の列番号 myLastCol = .Columns(.Columns.Count).Column End With Dim i As Integer For i = 7 To mylastRow '1 Sheets("問合せ回答一覧").Range("F3:J3") = Sheets("データ入力").Cells(i, 1).Value '2 Sheets("問合せ回答一覧").Range("F4:J4") = Sheets("データ入力").Cells(i, 2).Value '3 Sheets("問合せ回答一覧").Range("F5:J5") = Sheets("データ入力").Cells(i, 3).Value '4 Sheets("問合せ回答一覧").Range("H8:V8") = Sheets("データ入力").Cells(i, 4).Value '5 Sheets("問合せ回答一覧").Range("H9:V9") = Sheets("データ入力").Cells(i, 5).Value '6 Sheets("問合せ回答一覧").Range("H10:V10") = Sheets("データ入力").Cells(i, 6).Value '7 Sheets("問合せ回答一覧").Range("H11:V11") = Sheets("データ入力").Cells(i, 7).Value '8 Sheets("問合せ回答一覧").Range("H12:V12") = Sheets("データ入力").Cells(i, 8).Value '9 Sheets("問合せ回答一覧").Range("H13:V13") = Sheets("データ入力").Cells(i, 9).Value '10 Sheets("問合せ回答一覧").Range("H14:V14") = Sheets("データ入力").Cells(i, 10).Value '11 Sheets("問合せ回答一覧").Range("H15:V15") = Sheets("データ入力").Cells(i, 11).Value '12 Sheets("問合せ回答一覧").Range("H16:V16") = Sheets("データ入力").Cells(i, 12).Value '13 Sheets("問合せ回答一覧").Range("H17:V17") = Sheets("データ入力").Cells(i, 13).Value Sheets("問合せ回答一覧").PrintOut Next i = i + 1 End Sub ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- 締切済み
- Visual Basic
- エクセル マクロ 抽出
教えてください。 ○と記入されたセルを参照して、一つ上のセル・A列にある同じ行のセル・ 9行目にある同じ列のセルを抽出しようとしています。 下記の通り入力すると 行数=値.Rowでエラーが出たしまいました。 試行錯誤頑張りましたが解決できそうにありませんのでお力を貸して頂けないでしょうか。 Sub 抽出() Dim i, 行数, 列数 As Long Dim 値 As Range i = 0 行数 = 値.Row 列数 = 値.Column For Each 値 In Sheets("sheet1").Range("C12:R171") If 値.Value = "○" Then i = i + 1 With Sheets("sheet2") .Cells(i, 3).Value = Sheets("sheet1").Cells(行数, 1).Value .Cells(i, 4).Value = Sheets("sheet1").Cells(9, 列数).Value .Cells(i, 5).Value = 値.Offset(-1, 0).Value End With End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- (できる方)エクセルVBA印刷済を印刷しない
リストに追加された内容をチェックシートに差し込み印刷する運用を考えています。 リストは定期的に追加され、前回リストに追加した内容は今回の印刷は印刷しないように したいです。 例)10:00 1~3を入力/1~3を印刷済 11:00 4~6を入力/4~6を印刷する ※10:00の1~3hは再度印刷しないようにする ■したいこと 一度印刷した内容もリスト上にあれば、再度印刷されるので、印刷済フラグをたてて、 次回印刷は印刷済フラグをチェックし、再度印刷されないようにしたい ※現マクロは下記にしるしています。(モジュール1) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sub 流し込み印刷() Sheets("データ入力").Select Dim mylastRow As Long '最終行を格納する変数 Dim myLastCol As Integer '最終列を格納する変数 Dim myLastCell As String '最終セルを設定する変数 With ActiveSheet.UsedRange '対象はアクティブシートの使用中のセル '最終行の行番号 mylastRow = .Rows(.Rows.Count).Row '最終列の列番号 myLastCol = .Columns(.Columns.Count).Column End With Dim i As Integer For i = 7 To mylastRow '1 Sheets("問合せ回答一覧").Range("F3:J3") = Sheets("データ入力").Cells(i, 1).Value '2 Sheets("問合せ回答一覧").Range("F4:J4") = Sheets("データ入力").Cells(i, 2).Value '3 Sheets("問合せ回答一覧").Range("F5:J5") = Sheets("データ入力").Cells(i, 3).Value '4 Sheets("問合せ回答一覧").Range("H8:V8") = Sheets("データ入力").Cells(i, 4).Value '5 Sheets("問合せ回答一覧").Range("H9:V9") = Sheets("データ入力").Cells(i, 5).Value '6 Sheets("問合せ回答一覧").Range("H10:V10") = Sheets("データ入力").Cells(i, 6).Value '7 Sheets("問合せ回答一覧").Range("H11:V11") = Sheets("データ入力").Cells(i, 7).Value '8 Sheets("問合せ回答一覧").Range("H12:V12") = Sheets("データ入力").Cells(i, 8).Value '9 Sheets("問合せ回答一覧").Range("H13:V13") = Sheets("データ入力").Cells(i, 9).Value '10 Sheets("問合せ回答一覧").Range("H14:V14") = Sheets("データ入力").Cells(i, 10).Value '11 Sheets("問合せ回答一覧").Range("H15:V15") = Sheets("データ入力").Cells(i, 11).Value '12 Sheets("問合せ回答一覧").Range("H16:V16") = Sheets("データ入力").Cells(i, 12).Value '13 Sheets("問合せ回答一覧").Range("H17:V17") = Sheets("データ入力").Cells(i, 13).Value Sheets("問合せ回答一覧").PrintOut Next i = i + 1 End Sub ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- ベストアンサー
- Visual Basic
- Excel VBAを使った重複行の抜き出しについて教えてください
以下のような2シートから、重複する「商品番号」のあるsheet1の行を抜き出して、別シートに書き出したいと思っております。 sheet1 | A | B | C -+--------+-------+----- 1| | | -+--------+------+-------- 2|商品番号|商品名|責任者 -+--------+------+-------- 3| 123456| ガム|山田太郎 -+--------+------+-------- 4| 2345678| チョコ|田中花子 ・・・ sheet2 | A | B | C -+--------+-------+----- 1| | | -+--------+------+-------- 2|商品番号|商品名|責任者 -+--------+------+-------- 3| 3987624| | -+--------+------+-------- 4| 193678| | ・・・ そこでVBAを作成したのですが、例えば商品番号「222011001」の行を抜き出したいのに、「22011001」の行も一緒に抜き出してしまいます。 どこがいけないのか、教えて頂けないでしょうか。 作成したVBAは以下の通りです。 VBA初心者で本を見ながら作ったため、大変見にくくなっているかと思います。申し訳ありませんが、どなたかおわかりになる方がいらっしゃいましたら、どうぞ宜しくお願い致します。 Option Base 1 Option Explicit Sub 重複データ抽出書き直し() Dim シート(2) As Worksheet Dim 比較列(2) As Integer Dim 一致セル As Range Dim 検索範囲 As Range Dim i As Integer Set シート(1) = Sheets("sheet1") Set シート(2) = Sheets("sheet2") 比較列(1) = 1: 比較列(2) = 1 シート(2).Activate ActiveCell.CurrentRegion.Select Selection.Offset(1, 比較列(2) - 1) _ .Resize(Selection.Rows.Count - 1, 1) _ .Select Set 検索範囲 = Selection Sheets.Add After:=Sheets(Sheets.Count) シート(1).Activate ActiveCell.CurrentRegion.Select Selection.Resize(1).Copy With Sheets(Sheets.Count).Range("A1") If Application.Version >= 9 Then .PasteSpecial 8 End If .PasteSpecial End With For i = 2 To Selection.Rows.Count Set 一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value) If Not 一致セル Is Nothing Then Selection.Offset(i - 1).Resize(1) _ .Copy Sheets(Sheets.Count) _ .Range("A65536").End(xlUp) _ .Offset(1) End If Next i Sheets(Sheets.Count).Activate End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでもっと早く転記
エクセル2000です。 以下は、列をコピーし行にペーストする作業を含むVBAですが、もっとスマートに早く転記する方法がありましたらご教示ください。 お願いします。 Sub TEST() With Application .ScreenUpdating = False .Calculation = xlCalculationManual Sheets("データ").Range("B8:DH8").ClearContents With Sheets("入力") .Range("G8:G68").Copy Sheets("データ").Range("C8:BK8").PasteSpecial Paste:=xlValues, Transpose:=True .Range("G14:G15").Copy Sheets("データ").Range("BM8:BN8").PasteSpecial Paste:=xlValues, Transpose:=True Sheets("データ").Range("BQ8") = .Range("G21") Sheets("データ").Range("BR8") = .Range("G23") .Range("G25:G29").Copy Sheets("データ").Range("BS8:BW8").PasteSpecial Paste:=xlValues, Transpose:=True .Range("G32:G68").Copy Sheets("データ").Range("BX8:DH8").PasteSpecial Paste:=xlValues, Transpose:=True End With Application.CutCopyMode = False .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub
- ベストアンサー
- オフィス系ソフト
お礼
有難うございます、画像を添付するにはここを一旦終了しなくてはなりませんね。また、新しくエクセルVBARange3か所に合致する合計額3として質問を立ち上げますので宜しくお願いします。