| |
▼どぢょりん さん：
>最初の質問時と比べ、Sheet1・Sheet3ともに、若干変更されました。
まだ見てなくてすみません。
1.の「仕入先が複数」問題はちょっと置いておいて、
2.の Sheet2に10行以上のデータが抽出された時の、Sheet3の印刷方法です
が、今おやりになっているように、Sheet2 に10行を超えるデータがあった
ときは、1〜10行を 印刷した後、11行目以降を1行目にコピーしていく
方式が分かりやすいと、ぼくも思います。
ただ、書かれているコードはもうすこし簡単になりそうなので、2.の
問題を先に片づけておこうと、
ワークシート用の 変数WS2 と WS3を用意して、
以下のようにまとめてみました。
Sub 仕入先に○_印刷2()
Dim dic As Object
Dim dic2 As Object
Dim c As Range
Dim i As Long
Dim ss As String
Dim WS2 As Worksheet: Set WS2 = Worksheets(2)
Dim WS3 As Worksheet: Set WS3 = Worksheets(3)
Set dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
' シート2の[C1]セルから順に下方に、C列の「商品名」と
' F列の「仕入れ先」対応関係を辞書dicに格納していきます
With WS2
For Each c In .Range("C1", .Cells(.Rows.Count, 3).End(xlUp))
dic(c.Value) = c.Offset(, 3).Value
Next
End With
' 最後まで処理すると､dic 内には
' key Item
' ---------------
' 商品A A社
' 商品B B社
' 商品C C社
' 商品D D社
' のようなLOOKUPテーブルが作成されます。
With WS3
.Select
For Each c In .Range("F1").Resize(2, 2)
If Len(c.Value) > 0 Then
i = i + 1
dic2(c.Value) = i
End If
Next
' dic2には 「仕入れ先」に対応するセル位置番号をセットしています。
' この結果､dic2というもう一つのLOOKUP TABLEは
' （今回の例では）以下のようになります。
' key Item key Item
' ----------------------------
' A社 1 B社 2
' C社 3 その他 4
' dic2（「仕入れ先-セル位置番号」対応表）に取得してあるセル位置に
' 図形を描いていく処理をします｡
Dim y As Long
Do While Len(WS2.Range("B1").Text) > 0
.DrawingObjects.Delete
For y = 1 To 20 Step 2
Set c = .Cells(y, 3)
If Len(c.Value) = 0 Then Exit For
If dic.Exists(c.Value) Then
ss = dic(c.Value)
If dic2.Exists(ss) Then
i = dic2(ss) '辞書2 にある仕入れ先位置
Else
i = dic2.Count '「その他」の位置
End If
drawCircle c.Offset(, 3).Resize(2, 2).Item(i)
End If
Next
'仕入先の楕円囲みが終わったら、印刷
.PrintPreview '←デバッグのため プレビュー
'.PrintOut ←◆本来の印刷は こちら
'印刷が終わったら WS2のデータを上方向シフト
With WS2.Range("B1")
.CurrentRegion.Offset(10).Copy .Cells
End With
Loop
End With
Set dic = Nothing
Set dic2 = Nothing
End Sub
仕入先が複数ある問題はいったん置いておいて、
2.の問題に対して、↑のコードに書いたやりかたで、試してみて
くださいませんか？
どんな不具合が出るか、はたまた、思ったように印刷されるか？
|
|
kanabun
- 11/11/20(日) 1:53 -
