VBA将符合条件的单元格合并到1个单元格

walkevin

用VBA将   Sheet2 I列中符合条件的单元格     合并到       Sheet1的D6单元格中，
请帮忙指点一下代码怎么写？谢谢！

liulang0808

Sub 按钮1_Click()
    On Error Resume Next
    Application.ScreenUpdating = False
    arr = Application.Intersect(Sheets(2).Columns(9), Sheets(2).UsedRange)
    For j = 1 To UBound(arr)
        If Left(arr(j, 1), 2) = "错误" Then str1 = str1 & Chr(10) & arr(j, 1)
    Next j
    [d6] = Mid(str1, 2)
    Application.ScreenUpdating = True
End Sub

liulang0808

具体见附件内容

huang1314wei

1. Sub text()
   
2.     Dim arr, i%
   
3.     arr = Sheet2.Range("I1:I" & Sheet2.Range("I1048576").End(xlUp).Row)
   
4.     For i = 1 To UBound(arr)
   
5.     If arr(i, 1) <> "" And arr(i, 1) Like "错误*" Then
   
6.        If Range("D6") = "" Then
   
7.           Range("D6") = arr(i, 1)
   
8.        Else
   
9.         Range("D6") = Range("D6") & vbNewLine & arr(i, 1)
   
10.        End If
    
11.      End If
    
12.     Next
    
13. End Sub
    

复制代码

huang1314wei

附件如下

Book1.rar (16.32 KB, 下载次数: 37)

2015-7-9 20:01 上传

点击文件名下载附件

hlly888

Sub yy()
Range("d6")=""
Dim arr, i&
arr = Sheet2.Range("i2:i" & Sheet2.Range("i65536").End(3).Row)
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), "错误") > 0 Then [d6] = [d6] & arr(i, 1) & Chr(10)
    Next
End Sub

hlly888

Book1.zip (21.06 KB, 下载次数: 27)

2015-7-9 20:34 上传

点击文件名下载附件

凤翔时代

huang1314wei 发表于 2015-7-9 20:01
附件如下

借贴求助！想请老师帮看一下附件，内有情况说明，也是关于合并至一个单元格的问题，谢谢了

huang1314wei

凤翔时代 发表于 2018-3-27 21:26
借贴求助！想请老师帮看一下附件，内有情况说明，也是关于合并至一个单元格的问题，谢谢了

1. Sub test()
   
2.     Dim arr, i%, d As Object, j%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("A1").CurrentRegion
   
5.     Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents
   
6.     For i = 2 To UBound(arr)
   
7.         If Not d.exists(arr(i, 3)) Then
   
8.             Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
   
9.         End If
   
10.         If arr(i, 3) <> arr(i, 2) Then
    
11.             d(arr(i, 3))(arr(i, 2)) = ""
    
12.         End If
    
13.     Next
    
14.     With Sheet2
    
15.         j = 1
    
16.         For Each c In d.keys
    
17.             j = j + 1
    
18.             .Cells(j, 1) = j - 1
    
19.             .Cells(j, 2) = c
    
20.             .Cells(j, 3) = Join(d(c).keys, "；")
    
21.         Next
    
22.     End With
    
23. End Sub
    

复制代码

附件参考

关于合并至单元格的问题.rar (16.91 KB, 下载次数: 36)

2018-3-27 23:16 上传

点击文件名下载附件

凤翔时代

huang1314wei 发表于 2018-3-27 23:16
附件参考

谢谢老师，帮我解决了工作上的难题