[已解决]求助大神帮忙修改下程序,完成表一数据变动，表二的数据随时更新

cpq151721

如附件，程序编写时出现问题，不能完全符合自己要实现的内容，求帮助，模块代码也在附件中
下记代码已实现单元格的拆分合并，并取得数据，但还是不懂得如何做数据关联，求大神指导
具体实现就是假如“源数据”表中的蓝色行的J-AA列有更新，sheet2对应的J-AA列自动更新（最好是能单个对应关系进行更新）
Sub SVNtest()    Dim arr()
    Dim brr() As Long
    Dim str$, i&, k&, j&, s$, a$, b&, d$, l&, r&, mrgstr$
    arr = Sheets("源数据").[b4].CurrentRegion.Value
    ReDim brr(1 To (UBound(arr) + 2), 1 To 1)
    r = 3
    For i = 1 To (UBound(arr) - 3)
        str = "": k = 0: s = ""
        mrgstr = ""
        s = arr(i, 1)
        Do
            str = str & arr(i + k, 1)
            k = k + 1
        Loop Until arr(i + k, 1) Like "-------*"
        If InStr(s, "----") Then
        Else
            If InStr(s, "r") Then
                For l = 1 To 4
                    Sheets("Sheet2").Cells(r, l + 1).Value = Split(s, "|", , vbTextCompare)(l - 1)
                Next
            End If
            For j = i + 2 To i + k - 1
                mrgstr = mrgstr & arr(j, 1)
                mrgstr = mrgstr & " "
            Next
            Sheets("Sheet2").Cells(r, "F").Value = mrgstr  
            Range("J" & (i + 2), "AA" & (i + 2)).Copy Sheets("Sheet2").Range("J" & r)  
            Sheets("sheet2").Rows(r).Interior.ColorIndex = 0  
            r = r + 1
            i = i + k
        End If
    Next
End Sub

最佳答案

月排行榜 / 总排行榜

ppp710715

2014-6-11 13:35

1. Sub testppp()
   
2. Dim ar, i As Integer
   
3.   n = 2
   
4.    Sheets("sheet2").Cells.Clear
   
5. For i = 3 To Sheets("源数据").Cells(Rows.Count, 2).End(3).Row
   
6.   If Range("b" & i).Interior.ColorIndex = 33 Then
   
7.    ar = Split(Range("b" & i), "|")
   
8.    With Sheets("sheet2")
   
9.      n = n + 1
   
10.      .Cells(n, "a").Resize(1, 4) = ar
    
11.       Range("b" & i).EntireRow.Range("j1:aa1").Copy .Cells(n, "j")
    
12.    End With
    
13.   End If
    
14.   Next
    
15.   Sheets("sheet2").[a3:aa3].EntireColumn.AutoFit
    
16. End Sub
    

复制代码

跳转到最佳答案楼层

ppp710715

楼主要实现何功能？请明示。

cpq151721

ppp710715 发表于 2014-6-11 11:01
楼主要实现何功能？请明示。

现在要实现的功能是sheet2的J-AA列与表“源数据”的蓝色底J-AA同步，即源数据表的蓝色底J-AA列发生变化，sheet2的对应J-AA列也随着变化，最好别源数据变化一个，sheet2的所有数据随着更新（这样运行速度太慢）

ppp710715

表“源数据”的蓝色底J-AA所在行是否固定不变？

ppp710715

1. Sub testppp()
   
2. Dim ar, i As Integer
   
3.   n = 2
   
4.    Sheets("sheet2").Cells.Clear
   
5. For i = 3 To Sheets("源数据").Cells(Rows.Count, 2).End(3).Row
   
6.   If Range("b" & i).Interior.ColorIndex = 33 Then
   
7.    ar = Split(Range("b" & i), "|")
   
8.    With Sheets("sheet2")
   
9.      n = n + 1
   
10.      .Cells(n, "a").Resize(1, 4) = ar
    
11.       Range("b" & i).EntireRow.Range("j1:aa1").Copy .Cells(n, "j")
    
12.    End With
    
13.   End If
    
14.   Next
    
15.   Sheets("sheet2").[a3:aa3].EntireColumn.AutoFit
    
16. End Sub
    

复制代码

cpq151721

ppp710715 发表于 2014-6-11 13:35

多谢，明显写的简单多了。可以多唠叨一句么，可否实现“源数据”表的蓝色底字修改后，“sheet2”的数据自动更新，不用在执行宏文件

cpq151721

ppp710715 发表于 2014-6-11 13:35

额。。还是有问题，没有将段中的数据整合到sheet2的E列中。对于怎么实现自动更新的，能否告知下

ppp710715

cpq151721 发表于 2014-6-11 14:15
多谢，明显写的简单多了。可以多唠叨一句么，可否实现“源数据”表的蓝色底字修改后，“sheet2”的数据自 ...

可实现“源数据”表的蓝色底字修改后sheet2的数据自动更新:
按底色提取.rar (14.79 KB, 下载次数: 9)

2014-6-11 15:10 上传

点击文件名下载附件

ppp710715

cpq151721 发表于 2014-6-11 14:51
额。。还是有问题，没有将段中的数据整合到sheet2的E列中。对于怎么实现自动更新的，能否告知下

利用Worksheet_Change事件
Private  Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 28 Then
   Dim ar, i As Integer
  n = 2
   Sheets("sheet2").Cells.Clear
For i = 3 To Sheets("源数据").Cells(Rows.Count, 2).End(3).Row
  If Range("b" & i).Interior.ColorIndex = 33 Then
   ar = Split(Range("b" & i), "|")
   With Sheets("sheet2")
     n = n + 1
     .Cells(n, "a").Resize(1, 4) = ar
      Range("b" & i).EntireRow.Range("j1:aa1").Copy .Cells(n, "j")
   End With
  End If
  Next
  Sheets("sheet2").[a3:aa3].EntireColumn.AutoFit
End If
End Sub

cpq151721

ppp710715 发表于 2014-6-11 15:12
利用Worksheet_Change事件
Private  Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < ...

多谢大虾了，已经解决问题了。。。