简单的复制 插入 粘贴问题 ，希望能用vba解决

1e3e

详见附件：样表一 ，其中x列中 ：一、基本口粮田及农田水利        对应        1

                                                  （一）基本口粮田        对应        2

……………………………
依次类推。
现在执行的重复操作是：
在样表一x列中 ：查找1，获取1所在行号为4，查找2(除掉1外x列最小的数），获取2所在行号为5，复制行数为Rows(5-4－1)即复制0行（即不要复制）
……………………………………………………………………………………………………………………………………………………………………
    依次类推，在x列中 ：查找28所在行号为31,查找29(除掉上面取完的数后x列最小的数），获取29所在行号为33，复制行数为Rows(33-31－1)即复制1行（即复制rows(32)）
下面依次类推。

在“空表”中，在x列中 ：查找28并在其所在行插入复制行（即插入复制rows(32)）……………依次类推。
得到效果 如“效果”表

注：样表二 是将 "样表一"rows(4:30)、rows(33)、rows(40:49)删除后得到的，其中背景色为无色的部分是相同的。

zopey

Private Sub CommandButton1_Click()
Set dica = CreateObject("Scripting.Dictionary")
For i = 2 To 99
    If Cells(i, 24).Value > 0 Then dica(Cells(i, 24).Value) = i
Next
Set dicb = CreateObject("Scripting.Dictionary")
With Worksheets("空表")
For i = 2 To 444
    If .Cells(i, 24).Value > 0 Then dicb(.Cells(i, 24).Value) = i
Next
End With
Dim arr
For i = 57 To 1 Step -1
   If dica(i + 1) - dica(i) > 1 Then
      arr = Cells(dica(i) + 1, 1).Resize(dica(i + 1) - dica(i) - 1, 14)
      Sheets("空表").Rows(dicb(i) + 1).Resize(dica(i + 1) - dica(i) - 1).Insert (3)
      Sheets("空表").Cells(dicb(i) + 1, 1).Resize(dica(i + 1) - dica(i) - 1, 14) = arr
   End If
Next
End Sub

附件:   复件 问题.zip (198.33 KB, 下载次数: 27)

2018-3-21 11:19 上传

点击文件名下载附件

1e3e

zopey 发表于 2018-3-21 11:19
Private Sub CommandButton1_Click()
Set dica = CreateObject("Scripting.Dictionary")
For i = 2 To 99 ...

大虾，有如下问题：
1、代码执行后，没有复制“某县某镇某村渠道防渗工程”的49万元！！！
2、请再看一下我新上传的附件，我需要将 a县 、b县、c县……k县等10个县全部复制粘贴到 空表中，3、删除没有明细项的统计项后代码运行出错，希望您有空帮我看看
注：表“f县”中 （一）搬迁安置b计划下面没有 白色的明细项目，所以就把“（一）搬迁安置b计划”删除了。

1e3e

等待大虾的代码。
等待指教。
等到帮忙。

1e3e

人工置顶置顶，求帮助

1e3e

人呢？高手都 到那儿去了啊？

1e3e

希望有人能帮帮我的忙谢谢

1e3e

求走过路过的兄弟姐妹大哥大姐，求你们帮帮我吧

1e3e

vba 门外汉
等待大虾的代码。
等待指教。
等到帮忙。

1e3e

求求大佬们走过路过看一下，谢谢提出指导意见

1e3e

继续等好心人帮忙，谢谢

jacky0202

废了好多脑细胞以为看懂了，再看你的要求还是没看懂O(∩_∩)O哈哈~