[已解决]求代码

526753064

要求已在附件中！完成后会给最佳的

最佳答案

月排行榜 / 总排行榜

dsmch

2014-8-13 08:49

Sub Macro1()
Dim i&, j%, p$, s$
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    p = ""
    For j = 1 To [a1].End(xlToRight).Column
        If Cells(i, j).EntireRow.Hidden = False And Cells(i, j).EntireColumn.Hidden = False And Cells(i, j).Interior.ColorIndex = 3 Then
            p = p & "," & Cells(i, j)
        End If
    Next
     s = IIf(s = "", Mid(p, 2), s & vbCrLf & Mid(p, 2))
Next
[m13] = s
End Sub

跳转到最佳答案楼层

dsmch

Sub Macro1()
Dim i&, j%, p$, s$
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    p = ""
    For j = 1 To [a1].End(xlToRight).Column
        If Cells(i, j).EntireRow.Hidden = False And Cells(i, j).EntireColumn.Hidden = False And Cells(i, j).Interior.ColorIndex = 3 Then
            p = p & "," & Cells(i, j)
        End If
    Next
     s = IIf(s = "", Mid(p, 2), s & vbCrLf & Mid(p, 2))
Next
[m13] = s
End Sub

风林火山

错了，删除

526753064

dsmch 发表于 2014-8-13 08:49
Sub Macro1()
Dim i&, j%, p$, s$
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

其他都对，就是最最前面多了个换行

526753064

风林火山 发表于 2014-8-13 08:53

这个怎么看不太懂，而且结果也不对啊

526753064

526753064 发表于 2014-8-13 09:11
其他都对，就是最最前面多了个换行

我运气要实际中出现了一点问题，我实际的表格是，红色的填充是用条件格式显示出来的，代码运行.Cells(i - 1, j).Interior.ColorIndex = 3是返回fale，我用n=.Cells(i - 1, j).Interior.ColorIndex，其实是=2的，难道用条件格式填充的颜色代码不能识别吗

526753064

dsmch 发表于 2014-8-13 08:49
Sub Macro1()
Dim i&, j%, p$, s$
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

我实际中出现了一点问题，我实际的表格是，红色的填充是用条件格式显示出来的，代码运行.Cells(i - 1, j).Interior.ColorIndex = 3是返回fale，我用n=.Cells(i - 1, j).Interior.ColorIndex，其实是=2的，难道用条件格式填充的颜色代码不能识别吗

526753064

dsmch 发表于 2014-8-13 08:49
Sub Macro1()
Dim i&, j%, p$, s$
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

我改了一下，填充是用条件格式，代码能改吗

dsmch

Sub Macro1()
Dim i&, j%, p$, s$
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    p = ""
    For j = 1 To [a1].End(xlToRight).Column
        If Cells(i, j).EntireRow.Hidden = False And Cells(i, j).EntireColumn.Hidden = False And Application.CountIf([v3:z3], Cells(i, j)) = 1 Then
            p = p & "," & Cells(i, j)
        End If
    Next
     s = IIf(s = "", Mid(p, 2), s & vbCrLf & Mid(p, 2))
Next
[m13] = s
End Sub