Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2003|回复: 8

[已解决]如何实现不同表单符合条件单元格的逐格转录?

[复制链接]
发表于 2017-7-24 16:59 | 显示全部楼层 |阅读模式
代码如下:
不知道自己是不是能说清楚,这段代码目的是将sheet1,sheet2,sheet3里的含有批注的单元格,将单元格的值(是数字)按从上到下的顺序赋在sheet5内,将单元格的批注也转录制sheet5的已经转录的数字单元格右边。
由于检索到的第一个单元格值为14,总共含批注的单元格是87,所以最后录了似乎是87或者88行一样的值,都是14那格,问下大神们怎么改才对,这个循环我搞不定了。谢谢大神们!!!!

'自动录入
Private Sub CommandButton4_Click()
Dim a As Integer, cs As Integer, rs As Integer, z As Integer, i As Integer, j As Integer
'含批注单元格个数
s = 0
For i = 1 To 100
    For j = 1 To 100
        If Sheet1.Cells(i, j).Comment Is Nothing And Sheet2.Cells(i, j).Comment Is Nothing _
        And Sheet3.Cells(i, j).Comment Is Nothing Then
            s = s + 0
        Else
            s = s + 1
        End If
    Next j
Next i
z = Sheet5.UsedRange.Rows.Count
For j = 1 To s
        For cs = 1 To 100
            For rs = 1 To 100
                If Sheet1.Cells(rs, cs).Value <> "" Then
                    If Sheet1.Cells(rs, cs).Comment Is Nothing Then
                        Cells(1, 1).Select
                    Else
                        ActiveSheet.Cells(z + j, 3).Value = Sheet1.Cells(rs, cs).Value
                        ActiveSheet.Cells(z + j, 4).Value = Sheet1.Cells(rs, cs).Comment.Text
                    End If
                ElseIf Sheet2.Cells(rs, cs).Value <> "" Then
                    If Sheet2.Cells(rs, cs).Comment Is Nothing Then
                        Cells(1, 1).Select
                    Else
                        ActiveSheet.Cells(z + j, 3).Value = Sheet2.Cells(rs, cs).Value
                        ActiveSheet.Cells(z + j, 4).Value = Sheet2.Cells(rs, cs).Comment.Text
                    End If
                ElseIf Sheet3.Cells(rs, cs).Value <> "" Then
                    If Sheet3.Cells(rs, cs).Comment Is Nothing Then
                        Cells(1, 1).Select
                    Else
                        ActiveSheet.Cells(z + j, 3).Value = Sheet3.Cells(rs, cs).Value
                        ActiveSheet.Cells(z + j, 4).Value = Sheet3.Cells(rs, cs).Comment.Text
                    End If
                End If
        Next rs
    Next cs
Next j
End Sub

最佳答案
2017-7-25 09:56
  1. Private Sub CommandButton4_Click()
  2. Dim rngs As Range, rng As Range, arr(1 To 10000, 1 To 2), r&, sh&
  3. On Error Resume Next
  4. For sh = 2 To 4
  5.   Set rngs = Sheets(sh).Cells.SpecialCells(xlCellTypeComments)
  6.   If Not rngs Is Nothing Then
  7.     For Each rng In rngs
  8.       If rng <> "" Then
  9.         r = r + 1
  10.         arr(r, 1) = rng
  11.         arr(r, 2) = rng.Comment.Text
  12.       End If
  13.     Next rng
  14.   End If
  15. Next sh
  16. [c2].Resize(r, 2) = arr
  17. End Sub
复制代码
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-7-24 17:05 | 显示全部楼层
上个附件吧,不用这么复杂的应该。
回复

使用道具 举报

发表于 2017-7-24 17:11 | 显示全部楼层
Dim rngs As Range, rng As Range
Set rngs = Cells.SpecialCells(xlCellTypeComments)  '直接获取带批注的单元格区域
MsgBox rngs.Cells.Count        '能得到总单元格数
For Each rng In rngs
  s = s & "," & rng & "!" & rng.Comment.Text  '逐个获取单元格信息
Next
MsgBox s   '输出
这只是个简单的例子,输出形式修改下就好了。
回复

使用道具 举报

 楼主| 发表于 2017-7-24 17:29 | 显示全部楼层
大灰狼1976 发表于 2017-7-24 17:11
Dim rngs As Range, rng As Range
Set rngs = Cells.SpecialCells(xlCellTypeComments)  '直接获取带批注 ...

工位管理v1.5.zip (116.22 KB, 下载次数: 3)
回复

使用道具 举报

 楼主| 发表于 2017-7-25 09:40 | 显示全部楼层
大灰狼1976 发表于 2017-7-24 17:11
Dim rngs As Range, rng As Range
Set rngs = Cells.SpecialCells(xlCellTypeComments)  '直接获取带批注 ...

大神 求救啊。。现在代码我写成这样了
Private Sub CommandButton5_Click()
Dim rngs As Range, rng As Range, m As Integer, z As Integer, j As Integer
Set rngs = Cells.SpecialCells(xlCellTypeComments)  '直接获取带批注的单元格区域
m = rngs.Cells.Count      '能得到总单元格数
z = Sheet5.UsedRange.Rows.Count
For j = 1 To m
    For Each rng In rngs
        s = s & "," & rng & "!" & rng.Comment.Text  '逐个获取单元格信息
        ActiveSheet.Cells(z + 1, 3).Value = rng.Value
        ActiveSheet.Cells(z + 1, 4).Value = s  '输出
    Next
Next j
End Sub


但效果仍然和一开始一样 就是它逐行增加信息的时候 每行的信息都是一样的
回复

使用道具 举报

 楼主| 发表于 2017-7-25 09:45 | 显示全部楼层
大灰狼1976 发表于 2017-7-24 17:11
Dim rngs As Range, rng As Range
Set rngs = Cells.SpecialCells(xlCellTypeComments)  '直接获取带批注 ...

不对 这个按钮没法运行
工位管理1.jpg
是啥原因啊????
回复

使用道具 举报

发表于 2017-7-25 09:56 | 显示全部楼层    本楼为最佳答案   
  1. Private Sub CommandButton4_Click()
  2. Dim rngs As Range, rng As Range, arr(1 To 10000, 1 To 2), r&, sh&
  3. On Error Resume Next
  4. For sh = 2 To 4
  5.   Set rngs = Sheets(sh).Cells.SpecialCells(xlCellTypeComments)
  6.   If Not rngs Is Nothing Then
  7.     For Each rng In rngs
  8.       If rng <> "" Then
  9.         r = r + 1
  10.         arr(r, 1) = rng
  11.         arr(r, 2) = rng.Comment.Text
  12.       End If
  13.     Next rng
  14.   End If
  15. Next sh
  16. [c2].Resize(r, 2) = arr
  17. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-7-25 10:00 | 显示全部楼层

太感谢了!!!!!
这个代码我真的是怎么都不可能想出来了。。还得多学学
顺便问一下之前那个rngs=nothing是啥原因?
回复

使用道具 举报

发表于 2017-7-25 10:14 | 显示全部楼层
rngs=nothing就是在那个工作表中没有含批注的单元格。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 17:07 , Processed in 1.058475 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表