teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップに関する質問VBA オブジェクト（セレクトに格納した値）を別のブックに表示

編集履歴

質問編集履歴

25

2021/07/12 23:36

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -1,4 +1,4 @@
1
- **分からない点はsheet2.Cells(row2, col2) = colect.item(i) 以降のコレクトの値をループさせてブックに表示する方法****
1
+ **分からない点はsheet2.Cells(row2, col2) = colect.item(i) をコレクトの値をループさせて別のブックのセルに表示する方法****
2
2
 
3
3
  Const ST_ROW As Long=4
4
4
 

24

2021/07/12 23:36

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -38,7 +38,9 @@
38
38
 
39
39
  sheet1=Wb2.Worksheets("コピー元")
40
40
 
41
- Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
41
+ Set sheet2=Wb1.Worksheets("コピー先")
42
+
43
+ lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
42
44
 
43
45
  If sheet1.Cells(row, 4) >= 2 Then
44
46
 

23

2021/07/12 23:34

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

22

2021/07/12 23:34

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

21

2021/07/12 23:34

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -36,7 +36,9 @@
36
36
 
37
37
  Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set
38
38
 
39
- sheet1=Wb2.Worksheets("コピー元") Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
39
+ sheet1=Wb2.Worksheets("コピー元")
40
+
41
+ Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
40
42
 
41
43
  If sheet1.Cells(row, 4) >= 2 Then
42
44
 

20

2021/07/12 23:34

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -30,9 +30,13 @@
30
30
 
31
31
  Dim colect As Collection, item As Variant Set colect=New Collection sPath="Book11.xlsx"
32
32
 
33
- Set Wb1=ThisWorkbook 'コピー先ブック
33
+ Set Wb1=ThisWorkbook 'コピー先ブック
34
34
 
35
- Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set sheet1=Wb2.Worksheets("コピー元") Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
35
+
36
+
37
+ Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set
38
+
39
+ sheet1=Wb2.Worksheets("コピー元") Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
36
40
 
37
41
  If sheet1.Cells(row, 4) >= 2 Then
38
42
 

19

2021/07/12 23:34

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -32,7 +32,7 @@
32
32
 
33
33
  Set Wb1=ThisWorkbook 'コピー先ブック
34
34
 
35
- Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set sheet1=Wb2.Worksheets("コピー元") Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow '縦の最初と末尾
35
+ Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set sheet1=Wb2.Worksheets("コピー元") Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow
36
36
 
37
37
  If sheet1.Cells(row, 4) >= 2 Then
38
38
 

18

2021/07/12 23:33

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -1,6 +1,4 @@
1
- ** 分からない点はsheet2.Cells(row2, col2) = colect.item(i) 以降のコレクトの値をループさせてブックに表示する方法
1
+ **分からない点はsheet2.Cells(row2, col2) = colect.item(i) 以降のコレクトの値をループさせてブックに表示する方法****
2
-
3
- **
4
2
 
5
3
  Const ST_ROW As Long=4
6
4
 

17

2021/07/12 23:33

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

16

2021/07/12 23:32

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

15

2021/07/12 23:32

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -1,6 +1,6 @@
1
- 分からない点はsheet2.Cells(row2, col2) = colect.item(i) 以降のコレクトの値をループさせてブックに表示する方法
1
+ ** 分からない点はsheet2.Cells(row2, col2) = colect.item(i) 以降のコレクトの値をループさせてブックに表示する方法
2
2
 
3
-
3
+ **
4
4
 
5
5
  Const ST_ROW As Long=4
6
6
 

14

2021/07/12 23:32

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

13

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

12

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

11

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

10

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

9

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

8

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -2,6 +2,66 @@
2
2
 
3
3
 
4
4
 
5
+ Const ST_ROW As Long=4
6
+
7
+ Const ST_COL As Long=2
8
+
9
+ Sub 数と日付()
10
+
11
+ Dim Wb1 As Workbook
12
+
13
+ Dim Wb2 As Workbook
14
+
15
+ Dim ary() As String
16
+
17
+ Dim row As Long
18
+
19
+ Dim col As Long
20
+
21
+ Dim sheet1 As Worksheet
22
+
23
+ Dim sheet2 As Worksheet
24
+
25
+ Dim lastRow As Long
26
+
27
+ Dim lastcol As Long
28
+
29
+ Dim index As Long
30
+
31
+ Dim index2 As Long
32
+
33
+ Dim colect As Collection, item As Variant Set colect=New Collection sPath="Book11.xlsx"
34
+
35
+ Set Wb1=ThisWorkbook 'コピー先ブック
36
+
37
+ Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set sheet1=Wb2.Worksheets("コピー元") Set sheet2=Wb1.Worksheets("コピー先") lastRow=sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol=sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row=ST_ROW To lastRow '縦の最初と末尾
38
+
39
+ If sheet1.Cells(row, 4) >= 2 Then
40
+
41
+ For col=ST_COL To lastcol
42
+
43
+ ary(index, index2) = sheet1.Cells(row, col)
44
+
45
+ index2=index2+1
46
+
47
+ Next colect.Add ary End If index2 = 0
48
+
49
+ Next Dim row2 As Long
50
+
51
+ Dim col2 As Long
52
+
53
+ Dim i As Long
5
54
 
6
55
 
7
- Const ST_ROW As Long = 4Const ST_COL As Long = 2Sub 数と日付() Dim Wb1 As Workbook Dim Wb2 As Workbook Dim ary() As String Dim row As Long Dim col As Long Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim lastRow As Long Dim lastcol As Long Dim index As Long Dim index2 As Long Dim colect As Collection, item As Variant Set colect = New Collection sPath = "Book11.xlsx" Set Wb1 = ThisWorkbook 'コピー先ブック Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set sheet1 = Wb2.Worksheets("コピー元") Set sheet2 = Wb1.Worksheets("コピー先") lastRow = sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol = sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row = ST_ROW To lastRow '縦の最初と末尾 If sheet1.Cells(row, 4) >= 2 Then '2以上の時 For col = ST_COL To lastcol '横の最初と末 ary(index, index2) = sheet1.Cells(row, col) '価を格納する index2 = index2 + 1 '次の横の価に Next colect.Add ary End If index2 = 0 '横の価をリセット Next Dim row2 As Long Dim col2 As Long Dim i As Long For row2 = 2 To colect.Count For col2 = 1 To 4 sheet2.Cells(row2, col2) = colect.item(i) col2 = col2 + 1 Next col2 = 0 Next sheet2.Range("A1:D1").Value = sheet1.Range("B3:E3").Value With ActiveSheet .Range("A1").Sort key1:=.Range("D1"), order1:=xlAscending, Header:=xlYes End WithEnd Sub
56
+
57
+ **ここから下が不明点**
58
+
59
+ For row2=2 To colect.Count
60
+
61
+ For col2=1 To 4 sheet2.Cells(row2,
62
+
63
+ col2)=colect.item(i)
64
+
65
+ col2=col2+1 Next col2=0 Next
66
+
67
+ sheet2.Range("A1:D1").Value=sheet1.Range("B3:E3").Value With ActiveSheet .Range("A1").Sort key1:=.Range("D1"), order1:=xlAscending, Header:=xlYes End WithEnd Sub

7

2021/07/12 23:30

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

6

2021/07/12 12:41

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

5

2021/07/12 12:41

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

4

2021/07/12 12:41

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

3

2021/07/12 12:41

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

2

2021/07/12 12:41

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
File without changes

1

2021/07/12 12:41

投稿

maxsbezitaburu
maxsbezitaburu

スコア0

test CHANGED
File without changes
test CHANGED
@@ -1 +1,7 @@
1
+ 分からない点はsheet2.Cells(row2, col2) = colect.item(i) 以降のコレクトの値をループさせてブックに表示する方法
2
+
3
+
4
+
5
+
6
+
1
7
  Const ST_ROW As Long = 4Const ST_COL As Long = 2Sub 数と日付() Dim Wb1 As Workbook Dim Wb2 As Workbook Dim ary() As String Dim row As Long Dim col As Long Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim lastRow As Long Dim lastcol As Long Dim index As Long Dim index2 As Long Dim colect As Collection, item As Variant Set colect = New Collection sPath = "Book11.xlsx" Set Wb1 = ThisWorkbook 'コピー先ブック Set Wb2 = Workbooks("Book11.xlsx") 'コピー元（参照する）ブック Set sheet1 = Wb2.Worksheets("コピー元") Set sheet2 = Wb1.Worksheets("コピー先") lastRow = sheet1.Cells(Rows.Count, ST_COL).End(xlUp).row lastcol = sheet1.Cells(ST_ROW, Columns.Count).End(xlToLeft).Column ReDim ary(0, lastcol - ST_COL) For row = ST_ROW To lastRow '縦の最初と末尾 If sheet1.Cells(row, 4) >= 2 Then '2以上の時 For col = ST_COL To lastcol '横の最初と末 ary(index, index2) = sheet1.Cells(row, col) '価を格納する index2 = index2 + 1 '次の横の価に Next colect.Add ary End If index2 = 0 '横の価をリセット Next Dim row2 As Long Dim col2 As Long Dim i As Long For row2 = 2 To colect.Count For col2 = 1 To 4 sheet2.Cells(row2, col2) = colect.item(i) col2 = col2 + 1 Next col2 = 0 Next sheet2.Range("A1:D1").Value = sheet1.Range("B3:E3").Value With ActiveSheet .Range("A1").Sort key1:=.Range("D1"), order1:=xlAscending, Header:=xlYes End WithEnd Sub