Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7 Professional : Excel 2016)
グループでコピー
投稿日時: 18/07/19 07:19:52
投稿者: dorayama

件名であっているか不明ですが、教えて頂きたくお願いいたします。
下の表のようなデータがあります。
   A B C D
1 あ  ○ △ ×
2 い × □ △
3 う △ × ○
4 え  □ ○ ×
5 あ △ □ ○
6 え  × △ □
7 い  ○ ○ ×
8 う  △ □ ×
 
A列は会社名なのですが、日毎で新規社名で件数もまちまちで社数もまちまちです。会社名毎で印刷シートに
コピーして印刷したいのです。拙い説明で申し訳ございませんが、教えて頂きたくよろしくお願いいたします。

回答
投稿日時: 18/07/19 09:14:30
投稿者: WinArrow
投稿者のウェブサイトに移動

一般機能の「オートフィルタ」を使った方が簡単だし楽です。
 
コピーしなくてもそのまま印刷できます。

回答
投稿日時: 18/07/23 09:55:25
投稿者: George

WinArrowさんが書かれたようにオートフィルタで絞り込んで印刷するとして、
おそらくすべての社名を重複なく取得する方法で詰まっているのではないかと推測しました。
 
いろんな方法がありますが、一つの方法としてDictionaryオブジェクトを使う手があります。
詳しくはご自分で検索などして確かめてみてください。
 
もう1つの方法として作業領域(作業用シートでも可)が確保できるのであれば
A列の値をすべてコピーした後でExcelの機能である重複データの削除を行った上で
その値を変数に確保すれば上記と同じことが出来ます。
 
オートフィルタの部分はマクロの記録を行うことで記録できますので
ご自分でやってみてください。

回答
投稿日時: 18/07/23 10:24:29
投稿者: WinArrow
投稿者のウェブサイトに移動

dorayama さんの引用:
A列は会社名なのですが、日毎で新規社名で件数もまちまちで社数もまちまちです。会社名毎で印刷シートに
コピーして印刷したいのです。拙い説明で申し訳ございませんが、教えて頂きたくよろしくお願いいたします。

 
単純に「同じ文字列としての社名」のリストを印刷するだけが本来の目的なんでしょうか?

回答
投稿日時: 18/07/23 11:07:13
投稿者: TAKA君

力技ですが。参考になれば幸いです。
 

Sub 回答例()
    Dim i As Long, Lr As Long
    With ThisWorkbook.Sheets("Sheet1")
        .Range("Z:Z").ClearContents
        Lr = .Cells(Rows.Count, "A").End(xlUp).Row
        .Range(.Range("A2"), .Cells(Lr, "A")).Copy .Range("Z1")
        .Range("Z:Z").RemoveDuplicates Columns:=1, Header:=xlNo
        Lr = .Cells(Rows.Count, "Z").End(xlUp).Row
        For i = 1 To Lr
            If .AutoFilterMode Then .Range("A1").AutoFilter
            .Range("A1").AutoFilter FIELD:=1, Criteria1:=.Cells(i, "Z").Value
            .PrintOut
            .Range("A1").AutoFilter
        Next i
    End With
End Sub

投稿日時: 18/07/24 05:37:57
投稿者: dorayama

WinArrow さんの引用:
dorayama さんの引用:
A列は会社名なのですが、日毎で新規社名で件数もまちまちで社数もまちまちです。会社名毎で印刷シートに
コピーして印刷したいのです。拙い説明で申し訳ございませんが、教えて頂きたくよろしくお願いいたします。

 
単純に「同じ文字列としての社名」のリストを印刷するだけが本来の目的なんでしょうか?

 
並び替えはできるのですが、複数行のA社のデータを印刷、複数行のB社のデータを印刷との形にしたいのですが、毎回送られてくるデータの会社名が違い、会社数も違うので、行き詰ってしまいました。

回答
投稿日時: 18/07/24 15:37:48
投稿者: WinArrow
投稿者のウェブサイトに移動

>行き詰ってしまいました。
 行き詰っている原因が、いまいちはっきりしませんね?
  
オートフィルタの手操作を実施してみましたか?
  
「会社名が違う」とか「会社数がその都度違う」とかは、当たり前として、
  
印刷対象の会社数がどのくらいあって、
その件数が手作業では、困難なのか?
ということではないかと思います。
 

回答
投稿日時: 18/07/24 16:37:40
投稿者: Suzu

目的と問題点が要領を得ないので、コードが無いと何も進まない様ですね。。
 
ファイル形式はxlsx で、
 ワークブック名 : DATA.xlsx
 ワークシート名 : DATA
 テーブル構造 :

	A	B	C	D
1	あ	○	△	×
2	い	×	□	△
3	う	△	×	○
4	え	□	○	×
5	あ	△	□	○
6	え	×	△	□
7	い	○	○	×
8	う	△	□	×

(A1からデータ 列名無し)
 
 
ADOXでxlsxファイルに接続し、シート毎に纏めています。
印刷するのに、決まったフォーマットがあるなら、
CopyFromRecordset ではなく、ループ処理で処理しても良いでしょうし。。
必要部分は適宜改造してください。
 
 
Sub getXLSX()
    '要参照設定 Microsoft ActiveX DataObject 2.x ObjectLibrary
 
    'このマクロが書かれたファイルと同じフォルダに、DATA.xlsx ファイル 配置
    'ファイルにはヘッダー(列名)無し。シート名 「DATA」
 
    'xlsx ファイル名
    Const strXLSXFileName As String = "DATA.xlsx"
 
    Dim cn As ADODB.Connection
    Dim rs1 As ADODB.Recordset
    Dim rs2 As ADODB.Recordset
 
    Dim strSQL1 As String
    Dim strSQL2 As String
     
    Dim strPath As String
    Dim i As Integer
 
    strPath = ThisWorkbook.Path & "\" & strXLSXFileName
 
    Set cn = New ADODB.Connection
    With cn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HDR=NO"
        .Open strPath
    End With
    strSQL1 = "SELECT F1 FROM [DATA$] GROUP BY F1 ORDER BY F1;"
    strSQL2 = "SELECT * FROM [DATA$];"
 
    Set rs1 = New ADODB.Recordset
    Set rs2 = New ADODB.Recordset
    Set rs1 = cn.Execute(strSQL1)
 
    Do While Not rs1.EOF
        strSQL2 = "SELECT * FROM [DATA$] WHERE F1='" & rs1![F1] & "' ORDER BY F1;"
        Set rs2 = cn.Execute(strSQL2)
        If rs2.EOF = False Then
            With ThisWorkbook.Worksheets.Add(AFTER:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                For i = 0 To rs2.Fields.Count - 1
                    .Cells(1, i + 1) = rs2.Fields(i).Name
                Next i
                .Range("A2").CopyFromRecordset rs2
                .Name = rs1![F1]
                rs2.Close
            End With
        End If
        rs1.MoveNext
    Loop
 
    cn.Close
    Set rs2 = Nothing: Set rs1 = Nothing
    Set cn = Nothing
End Sub

トピックに返信