[已解决][VBA求助]批量查找整理数据的格式

yvhanym

详细问题和说明请下载附件查看。谢谢！

vba求助.rar (9.31 KB, 下载次数: 14)

2012-3-29 13:33 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-3-29 15:25

1. 
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     If Target.Address = "$A$1" Then
   
4.         Dim S$, Arr, i&, Ar() As String, j&
   
5.         S = Target.Value
   
6.         Arr = Sheet2.Range("A1").CurrentRegion.Value
   
7.         ReDim Ar(1 To UBound(Arr, 2) - 4, 1 To 5)
   
8.         For i = 1 To UBound(Ar)
   
9.             Ar(i, 1) = Arr(1, i + 4)
   
10.             Ar(i, 2) = Application.Text(Ar(i, 1), "aaaaa")
    
11.             For j = 2 To UBound(Arr)
    
12.                 If Arr(j, i + 4) = S Then
    
13.                     If Len(Ar(i, 3)) Then
    
14.                         Ar(i, 3) = Ar(i, 3) & vbCrLf & _
    
15.                             Application.Text(Arr(j, 2), "h:m") & "-" & _
    
16.                             Application.Text(Arr(j, 3), "h:m")
    
17.                         Ar(i, 4) = Ar(i, 4) & vbCrLf & Arr(j, 4)
    
18.                         Ar(i, 5) = Ar(i, 5) & vbCrLf & Arr(j, 1)
    
19.                     Else
    
20.                         Ar(i, 3) = Application.Text(Arr(j, 2), "h:m") & "-" & _
    
21.                             Application.Text(Arr(j, 3), "h:m")
    
22.                         Ar(i, 4) = Arr(j, 4)
    
23.                         Ar(i, 5) = Arr(j, 1)
    
24.                     End If
    
25.                 End If
    
26.             Next j
    
27.             If Len(Ar(i, 3)) = 0 Then Ar(i, 3) = "休息"
    
28.         Next i
    
29.         Application.ScreenUpdating = False
    
30.         Application.DisplayAlerts = False
    
31.         Range("a3:e" & Rows.Count).Clear
    
32.         With Range("a3").Resize(UBound(Ar), 5)
    
33.             .Value = Ar
    
34.             .Borders.LineStyle = 1
    
35.         End With
    
36.         Application.DisplayAlerts = True
    
37.         Application.ScreenUpdating = True
    
38.     End If
    
39. End Sub

复制代码

vba求助.rar (14.49 KB, 下载次数: 24)

2012-3-29 15:24 上传

点击文件名下载附件
表一数据全部自动更新
只用选择表一的A1单元格和更新表二即可

一天有相同 记录的以换行分隔出来。

跳转到最佳答案楼层

youxinggy

太复杂了，不好弄

yvhanym

youxinggy 发表于 2012-3-29 13:46
太复杂了，不好弄

那就难怪我整理不出来了，你都说复杂了，说明这个问题真的就算是个问题。
看来不只是我觉得难啊，求高手出马助小弟一臂之力~~~

hrpotter

要是一天有二条以上记录怎么处理呀？

yvhanym

hrpotter 发表于 2012-3-29 15:06
要是一天有二条以上记录怎么处理呀？

时间1/时间2    地点1/地点2

liuguansky

1. 
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     If Target.Address = "$A$1" Then
   
4.         Dim S$, Arr, i&, Ar() As String, j&
   
5.         S = Target.Value
   
6.         Arr = Sheet2.Range("A1").CurrentRegion.Value
   
7.         ReDim Ar(1 To UBound(Arr, 2) - 4, 1 To 5)
   
8.         For i = 1 To UBound(Ar)
   
9.             Ar(i, 1) = Arr(1, i + 4)
   
10.             Ar(i, 2) = Application.Text(Ar(i, 1), "aaaaa")
    
11.             For j = 2 To UBound(Arr)
    
12.                 If Arr(j, i + 4) = S Then
    
13.                     If Len(Ar(i, 3)) Then
    
14.                         Ar(i, 3) = Ar(i, 3) & vbCrLf & _
    
15.                             Application.Text(Arr(j, 2), "h:m") & "-" & _
    
16.                             Application.Text(Arr(j, 3), "h:m")
    
17.                         Ar(i, 4) = Ar(i, 4) & vbCrLf & Arr(j, 4)
    
18.                         Ar(i, 5) = Ar(i, 5) & vbCrLf & Arr(j, 1)
    
19.                     Else
    
20.                         Ar(i, 3) = Application.Text(Arr(j, 2), "h:m") & "-" & _
    
21.                             Application.Text(Arr(j, 3), "h:m")
    
22.                         Ar(i, 4) = Arr(j, 4)
    
23.                         Ar(i, 5) = Arr(j, 1)
    
24.                     End If
    
25.                 End If
    
26.             Next j
    
27.             If Len(Ar(i, 3)) = 0 Then Ar(i, 3) = "休息"
    
28.         Next i
    
29.         Application.ScreenUpdating = False
    
30.         Application.DisplayAlerts = False
    
31.         Range("a3:e" & Rows.Count).Clear
    
32.         With Range("a3").Resize(UBound(Ar), 5)
    
33.             .Value = Ar
    
34.             .Borders.LineStyle = 1
    
35.         End With
    
36.         Application.DisplayAlerts = True
    
37.         Application.ScreenUpdating = True
    
38.     End If
    
39. End Sub

复制代码

vba求助.rar (14.49 KB, 下载次数: 24)

2012-3-29 15:24 上传

点击文件名下载附件
表一数据全部自动更新
只用选择表一的A1单元格和更新表二即可

一天有相同 记录的以换行分隔出来。

hrpotter

yvhanym 发表于 2012-3-29 15:10
时间1/时间2    地点1/地点2

1. Sub test()
   
2.     Dim ar, br(), cr(), st
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     ar = Sheet2.Range("a1").CurrentRegion
   
5.     With Sheet1
   
6.         .Range("a3:e65536").ClearContents
   
7.         st = .Range("a1").Value
   
8.         ReDim br(1 To 1000, 1 To 5)
   
9.         ReDim cr(1 To UBound(ar, 2) - 4, 1 To 5)
   
10.         For i = 5 To UBound(ar, 2)
    
11.             cr(i - 4, 1) = ar(1, i)
    
12.             For j = 2 To UBound(ar)
    
13.                 If ar(j, i) = st Then
    
14.                     k = k + 1
    
15.                     br(k, 1) = ar(1, i)
    
16.                     br(k, 3) = Format(ar(j, 2), "h:mm") & "-" & Format(ar(j, 3), "h:mm")
    
17.                     br(k, 4) = ar(j, 4)
    
18.                     br(k, 5) = ar(j, 1)
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.         For i = 1 To UBound(cr)
    
23.             cr(i, 2) = Right(Format(cr(i, 1), "aaaa"), 1)
    
24.             For j = 1 To k
    
25.                 If br(j, 1) = cr(i, 1) Then
    
26.                     cr(i, 3) = cr(i, 3) & "/" & br(j, 3)
    
27.                     cr(i, 4) = cr(i, 4) & "/" & br(j, 4)
    
28.                     cr(i, 5) = cr(i, 5) + br(j, 5)
    
29.                 End If
    
30.             Next
    
31.         Next
    
32.         For i = 1 To UBound(cr)
    
33.             If cr(i, 3) = "" Then
    
34.                 cr(i, 3) = "休息"
    
35.             Else
    
36.                 cr(i, 3) = Right(cr(i, 3), Len(cr(i, 3)) - 1)
    
37.                 cr(i, 4) = Right(cr(i, 4), Len(cr(i, 4)) - 1)
    
38.             End If
    
39.         Next
    
40.         .Range("a3").Resize(UBound(cr), 5) = cr
    
41.     End With
    
42. End Sub

复制代码

yvhanym

hrpotter 发表于 2012-3-29 15:35

可否麻烦修改下：
1、如果一天有两个时间段，格式为（时间段1/时间段2）
2、如果一天有两个地点，格式为（地点1/地点2）
3、一天如果有两个时长，可否求和

谢谢！

yvhanym

hrpotter 发表于 2012-3-29 15:35

完全满足。谢谢！！！强烈感谢！！！！

蓝桥玄霜

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Address <> "$A$1" Then Exit Sub
   
4. If Target = "" Then Exit Sub
   
5. Dim aa, r1, ad$, rq, sj$, sc, dd, n&
   
6. [c3:e32].ClearContents
   
7. aa = Target.Value
   
8. With Sheet2
   
9.     Set r1 = .Cells.Find(aa, , , 1)
   
10.     If Not r1 Is Nothing Then
    
11.         ad = r1.Address
    
12.         rq = .Cells(1, r1.Column): n = Day(rq) + 2
    
13.         sj = Format(.Cells(r1.Row, 2), "hh:mm") & "-" & Format(.Cells(r1.Row, 3), "hh:mm")
    
14.         sc = .Cells(r1.Row, 1)
    
15.         dd = .Cells(r1.Row, 4)
    
16.         Cells(n, 3) = sj
    
17.         Cells(n, 4) = dd
    
18.         Cells(n, 5) = sc
    
19.         Do
    
20.             Set r1 = .Cells.FindNext(r1)
    
21.             If Not r1 Is Nothing Then
    
22.                 If r1.Address <> ad Then
    
23.                     rq = .Cells(1, r1.Column): n = Day(rq) + 2
    
24.                     sj = Format(.Cells(r1.Row, 2), "hh:mm") & "-" & Format(.Cells(r1.Row, 3), "hh:mm")
    
25.                     sc = .Cells(r1.Row, 1)
    
26.                     dd = .Cells(r1.Row, 4)
    
27.                     Cells(n, 3) = sj
    
28.                     Cells(n, 4) = dd
    
29.                     Cells(n, 5) = sc
    
30.                 End If
    
31.             End If
    
32.         Loop While Not r1 Is Nothing And r1.Address <> ad
    
33.     End If
    
34. End With
    
35. End Sub
    

复制代码