[已解决]麻烦老师帮我看看，如何修改代码。

love_liwu · 发表于 2016-12-14 09:13

老师，您好，麻烦帮我看看，如何修改代码？说明：即便是同个区域代码和名称，只要是区域小类不同，就当做新的数据，如

Book1.zip (4.59 KB, 下载次数: 3)

2016-12-14 09:13 上传

点击文件名下载附件图示，请问怎么修改代码？
Set dic = CreateObject("scripting.dictionary")
With ThisWorkbook
  .Sheets(2).UsedRange.Cells.Clear
  .Sheets(1).Rows(1).Copy .Sheets(2).Rows(1)
  arr = .Sheets(1).Range("a1").CurrentRegion
  For k = 2 To UBound(arr, 1)

   If Not dic.exists(arr(k, 1)) Then
      r = .Sheets(2).Range("a" & Rows.Count).End(xlUp).Row + 1
      .Sheets(1).Rows(k).Copy .Sheets(2).Range("a" & r)
      dic(arr(k, 1)) = r
   Else
      l = .Sheets(2).Cells(dic(arr(k, 1)), Columns.Count).End(xlToLeft).Column
      .Sheets(1).Range("D" & k & ":H" & k).Copy .Sheets(2).Cells(dic(arr(k, 1)), l + 1)
      .Sheets(1).Range("D1:H1").Copy .Sheets(2).Cells(1, l + 1)

   End If
Next
假设有以下数据（实际不止）

区域代码	区域小类	名称	会员时间	变动类型	身份证明类别	身份证明号码	姓名
HNDQ（华南地区）	GD（广东）	张三集团	201607	新增	身份证	44*****	张1
HNDQ（华南地区）	GD（广东）	张三集团	201607	新增	身份证	44*****	张2
HNDQ（华南地区）	GD（广东）	张三集团	201607	新增	身份证	44*****	张3
HNDQ（华南地区）	GD（广东）	张三集团	201607	新增	身份证	44*****	张4
HNDQ（华南地区）	HN（海南）	张三集团	201607	新增	身份证	51*****	刘1
HNDQ（华南地区）	HN（海南）	张三集团	201607	新增	身份证	51*****	刘2
HNDQ（华南地区）	HN（海南）	张三集团	201607	新增	身份证	51*****	刘3
HNDQ（华南地区）	HN（海南）	张三集团	201607	新增	身份证	51*****	刘4
HNDQ（华南地区）	HN（海南）	张三集团	201607	新增	身份证	51*****	刘5
HBDQ（华北地区）	BJ（北京）	李四集团	201607	新增	身份证	1***	刘6

效果图：

效果：

区域代码

区域小类

名称

会员时间

变动类型

身份证明类别

身份证明号码

姓名

会员时间

变动类型

身份证明类别

身份证明号码

姓名

会员时间

变动类型

身份证明类别

身份证明号码

姓名

会员时间

变动类型

身份证明类别

身份证明号码

姓名

会员时间

变动类型

身份证明类别

身份证明号码

姓名

HNDQ（华南地区）

GD（广东）

张三集团

201607

新增

身份证

44*****

张1

201607

新增

身份证

44*****

张2

201607

新增

身份证

44*****

张3

201607

新增

身份证

44*****

张4

HNDQ（华南地区）

HN（海南）

张三集团

201607

新增

身份证

51*****

刘1

201607

新增

身份证

51*****

刘2

201607

新增

身份证

51*****

刘3

201607

新增

身份证

51*****

刘4

201607

新增

身份证

51*****

刘5

HBDQ（华北地区）

BJ（北京）

李四集团

201607

新增

身份证

**1*****

刘6

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-14 10:12

结果显示在22行开始。

Sub tt()
Set d = CreateObject("scripting.dictionary")
arr = Sheets(1).Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 1000)
ReDim nn(1 To UBound(arr))
For k = 1 To UBound(arr, 1)
x = arr(k, 1) & arr(k, 2) & arr(k, 3)
If Not d.exists(x) Then
n = n + 1: d(x) = n
For j = 1 To UBound(arr, 2)
brr(n, j) = arr(k, j)
Next
nn(n) = UBound(arr, 2)
Else
p = d(x)
For j = 1 To 5
brr(p, nn(p) + j) = arr(k, j + 3)
brr(1, nn(p) + j) = arr(1, j + 3)
Next
nn(p) = nn(p) + 5
End If
Next
If n > 0 Then [a22].Resize(n, Application.Max(nn)) = brr
End Sub

复制代码

跳转到最佳答案楼层

grf1973 · 发表于 2016-12-14 09:58

为什么要横过来写呢？原来的数据格式很好啊。

grf1973 · 发表于 2016-12-14 10:12

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

结果显示在22行开始。

Sub tt()
Set d = CreateObject("scripting.dictionary")
arr = Sheets(1).Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 1000)
ReDim nn(1 To UBound(arr))
For k = 1 To UBound(arr, 1)
x = arr(k, 1) & arr(k, 2) & arr(k, 3)
If Not d.exists(x) Then
n = n + 1: d(x) = n
For j = 1 To UBound(arr, 2)
brr(n, j) = arr(k, j)
Next
nn(n) = UBound(arr, 2)
Else
p = d(x)
For j = 1 To 5
brr(p, nn(p) + j) = arr(k, j + 3)
brr(1, nn(p) + j) = arr(1, j + 3)
Next
nn(p) = nn(p) + 5
End If
Next
If n > 0 Then [a22].Resize(n, Application.Max(nn)) = brr
End Sub

复制代码

love_liwu · 发表于 2016-12-14 10:20

grf1973 发表于 2016-12-14 10:12
结果显示在22行开始。

谢谢老师耐心指导，横着写，有利于清楚。那如果不横着写，应该怎么写。

grf1973 · 发表于 2016-12-14 10:30

原来那种写法是最好的数据格式，标准的二维数据库结构，便于查询，汇总等各种处理。

love_liwu · 发表于 2016-12-14 20:20

grf1973 发表于 2016-12-14 10:30
原来那种写法是最好的数据格式，标准的二维数据库结构，便于查询，汇总等各种处理。

我能理解，感谢老师耐心指导！也麻烦老师帮我看看：继续追问：麻烦老师帮我修改下代码
http://www.excelpx.com/thread-426380-1-1.html
(出处: Excel精英培训网)

雄鹰2013 · 发表于 2017-8-12 15:05

学习

		自动登录	找回密码
密码			注册