前言

有小伙伴每天需要从微信信息中，复制数据粘贴到excel进行处理。一般都是临下班时，一大堆信息来袭，需要赶在下班前录入完成并将汇总结果报给老板。小伙伴是个手脚麻利的二逼青年，每次任务到来时复制粘贴的速度让人好生佩服，但挨不住时间紧任务重，那心中的苦也是如草原上的万马齐奔啊。不过，自从学会这一招后，万马齐奔妙变万马齐喑，轻轻松松提前下班。不多说了，盘他……

模拟案例

案例模拟的微信收到的信息，如有雷同，就雷同吧，汇总表如下：

咋眼一看，也就是复制粘贴最直接了。但是，这都快22世纪了，还用复制粘贴怎么可以容忍，是时候放大招了。

解决方案

一键解决，用到第二步算我输。复制好收到的信息后，鼠标左键单击汇总表中B列对应的店名。比如，复制的是西安钟楼店的数据，就单击B列中的B2单元格（西安钟楼），数据输入完成，真的不用粘贴。

有时候数据行太多了，小伙伴找到对应的单元格比较困难咋办，没事儿，随便点击B列的合计行以上的任一行，表格会提醒你应该点哪里的。一是为了便于找到，二来也避免了输错了位置。

那每天都接受到数据，万一复制信息时搞错了，误把昨天的数据当成当天的数据给复制了咋办？也不用怕，汇总表中第一列的日期是根据复制的信息自动生成的，当遇到不一样的日期时，会变色提醒，而且，这个时候也不能进行汇总，让你交不了错误的数据给老板。

到这个时候，你会发现，合计行的数据都没有出现，还要用sum汇总吗？别闹，说好的一键解决，sum起开。输入完成后，点击一下合计单元格，汇总数就会出现了，而且只有当你把所有数据都输入全，而且日期都是一致的时候，汇总数才会出现哦。要是把每个店的数据都给错误地复制成同一天的了，咋办？老板，他成心的，这锅不背。

效果如下：

重点说明

案例用了VBA代码解决，主要在两个方面：

1、用Worksheet_SelectionChange()，实现当单击B列指定区域单元格时，触发事件，依次从剪贴板中提取数据写入对应的单元格中，重点是用到了对剪贴板的操作。

2、用Sub 提醒()，实现了当点击了B列不是对应的单元格时，让正确的点击位置单元格出现闪动提醒。

3、日期不一致时的变色提醒，就是条件格式设置了，这个没啥说的。

4、重点提醒：有个小BUG召唤大家来抓哦。

具体代码附后，有兴趣的欢迎留言交流。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim a As New DataObject, b() As String, i, j As Integer, bl As Boolean

Set a = New DataObject

On Error Resume Next

bl = False

Dim re As Object

Set re = CreateObject("VBScript.Regexp")

re.Global = True: re.Pattern = "[\\r\\n]+"

i = Target.Row '点击B列填入数据

If i < [b30000].End(3).Row And i > 1 And Target.Column = 2 Then

a.GetFromClipboard

s = re.Replace(a.GetText, vbCrLf)

b = Split(s, vbCrLf)

For k = 2 To [b30000].End(3).Row

If Len(b(0)) < 4 Then Exit Sub

If Cells(k, 2) = Left(b(0), 4) Then

bl = True

Exit For

End If

Next

If bl = False Then Exit Sub

If Cells(i, 2) = Left(b(0), 4) Then

Cells(i, 3).Resize(1, 6).ClearContents

Cells(i, 1) = Mid(b(0), 6, 4)

Cells(i, 3) = Application.WorksheetFunction.Substitute(Mid(b(1), 4, 99), "万元", "")

For j = 4 To UBound(b) + 2

Cells(i, j) = Application.WorksheetFunction.Substitute(Mid(b(j - 2), 4, 99), "件", "")

Next

Cells([b30000].End(3).Row, 3).Resize(1, 6).ClearContents

Else

n1 = Application.WorksheetFunction.Match(Left(b(0), 4), Cells(1, 2).Resize(6, 1), 0)

nname = Left(b(0), 4)

Call 提醒

End If

Erase b

End If

If Target.Row = [b30000].End(3).Row And Target.Column = 2 Then

For i = 3 To [b30000].End(3).Row - 2

If Cells(i, 1) <> Cells(2, 1) Then

MsgBox "数据未全或日期有误，不能汇总，请检查"

Exit Sub

End If

Next

For j = 3 To 8

Cells([b30000].End(3).Row, j) = Application.WorksheetFunction.Sum(Cells(2, j).Resize([b30000].End(3).Row - 2, 1))

Next

End If

End Sub

Public n1 As Integer, nname As String

Sub 提醒()

Dim n As Integer, i As Long

For n = 1 To 100

Cells(n1, 2).Interior.ColorIndex = 3

Cells(n1, 2) = "我在这里"

For i = 1 To 100000

Next

Cells(n1, 2).Interior.ColorIndex = xlNone

For i = 1 To 100000

Next

Next

Cells(n1, 2) = nname

End Sub