[已解决]如何让符合条件的单元格数据从上到下顺序提取再拷贝？

ww0000

以下是将符合一种颜色的单元格的值copy到另外一个sheet，但他是从左到右的顺序提取再拷贝，
现在我想问的是：如何让数据从上到面的顺序提取再拷贝 Book1.rar (6.56 KB, 下载次数: 23)

2012-7-4 12:44 上传

点击文件名下载附件


Sub yyy()
Dim rng As Range, myRng As Range
a = Sheet2.Range("B65536").End(xlUp).Row
Set myRng = Sheet1.Range("A1:D6")
For Each rng In myRng
If rng.Interior.ColorIndex = 6 Then
        rng.Copy
        Sheet2.Cells(a + 1, 1).PasteSpecial
        a = a + 1
        Calculate  
End If
Next
End Sub

最佳答案

月排行榜 / 总排行榜

ws278106483

2012-7-4 13:10

1. Sub xh()
   
2. Dim x As Integer
   
3. Dim y As Integer
   
4. a = 1
   
5. For x = 1 To 4
   
6.     For y = 1 To 5
   
7.      If Cells(y, x).Interior.ColorIndex = 6 Then
   
8.         
   
9.         Sheets("sheet2").Cells(a + 1, 1).Value = Cells(y, x).Value
   
10.         
    
11.         a = a + 1
    
12.       End If
    
13.     Next y, x
    
14. End Sub

复制代码

更完美了。呵呵。

跳转到最佳答案楼层

gdsgzhrsh

FOR EACH 做循环的话是先行后列的进行循环
试试这个代码
Sub CC()
K = 2
For I = 1 To 4
For J = 1 To 5
If Cells(J, I).Interior.ColorIndex = 6 Then
Sheet3.Cells(K, 1) = Cells(J, I)
K = K + 1
End If
Next
Next

End Sub

ws278106483

1. Sub xh()
   
2. Dim x As Integer
   
3. Dim y As Integer
   
4. For x = 1 To 4
   
5.     For y = 1 To 5
   
6.      If Cells(y, x).Interior.ColorIndex = 6 Then
   
7.         
   
8.         Sheets("sheet2").Cells(a + 1, 1).Value = Cells(y, x).Value
   
9.         
   
10.         a = a + 1
    
11.       End If
    
12.     Next y, x
    
13. End Sub

复制代码

ws278106483

1. Sub xh()
   
2. Dim x As Integer
   
3. Dim y As Integer
   
4. a = 1
   
5. For x = 1 To 4
   
6.     For y = 1 To 5
   
7.      If Cells(y, x).Interior.ColorIndex = 6 Then
   
8.         
   
9.         Sheets("sheet2").Cells(a + 1, 1).Value = Cells(y, x).Value
   
10.         
    
11.         a = a + 1
    
12.       End If
    
13.     Next y, x
    
14. End Sub

复制代码

更完美了。呵呵。

ww0000

谢谢上面两位老师的指点，但是两位的代码还是不能满足我的要求，只能得到数值，不能得到格式。
我根据ws278106483 老师的指点，改进了我的代码，现在可以达到要求了！

Sub yyy2()
Dim myRng As Range
a = Sheet2.Range("B65536").End(xlUp).Row
Set myRng = Sheet1.Range("A1:D6")
Dim x As Integer
Dim y As Integer
For x = 1 To 4
For y = 1 To 5
If Cells(y, x).Interior.ColorIndex = 6 Then
        Cells(y, x).Copy
        Sheet2.Cells(a + 1, 1).PasteSpecial
        a = a + 1
        Calculate
End If
Next y, x
End Sub