使用VBA如何将总表数据复制到各分表中

harryfooty

现在的手动工作的方式：框选，ctrl+C复制总表数据，再到每个分表ctrl+V粘贴，有近30个表，每个表都有不定数量的厅号，需要复制到对应的厅号旁；请教大神们用vba的方法；
目前我觉得难度的地方是：
1、虽然分表结构都是一样的，但是厅号一栏是合并单元格；
2、看了一些群友的例子，发现对应关系不好写；


目前的一些思路：
1、用数据.copy的方法把总表数据复制到各分表中；
2、首先判断要复制的数据范围，我人工操作复制，每次都是选择连续的区域，就是每家影城中，相同影厅为一个区域；（这里不知到用什么办法识别出每个区域）；
3、然后要复制的地方行在哪？（我觉得可以判断每个分表的名字去activate每个分表，然后用字典记住厅号，来确定复制的行号啥的，列号都是固定区域，是D:H列；

就想到这么多了。。
先谢谢各位坛友！

harryfooty

朱荣兴 发表于 2019-1-23 07:38
应该就是个拆分问题吧，到我的主题里下载     灵活拆分工具  吧

老师，我还是搞不懂，学到了一个字典的key也可以作为循环顺序创建分表外，其它还是不懂修改...我的表格还有合并单元格，得通过影城确定要复制到哪张表，通过影厅确定复制到的行位置，跟根据单个参数的拆分有点不同，我这个得根据影城影厅两个参数确定复制位置，我这种情况应该用怎样的思路和办法解决呢？

05050818

Sub 分配()
Application.ScreenUpdating = False
Dim Conn As Object, Rst As Object
Dim strConn As String, strSQL As String
Dim i As Integer, PathStr As String

Set Conn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")

PathStr = ThisWorkbook.FullName
Select Case Application.Version * 1
    Case Is <= 11
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    Case Is >= 12
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
End Select
Conn.Open strConn
Set reg = CreateObject("VbScript.RegExp")
reg.Pattern = "\W+"
Set d = CreateObject("Scripting.Dictionary")
Set sh = Sheets("数据")
With sh
  r = .Cells(.Rows.Count, 1).End(3).Row
     For i = 2 To r
       d(.Cells(i, 4).Value) = ""
     Next
       ar = d.keys
End With
For Each st In Sheets
  If st.Name <> "数据" Then
         sn = st.Name
         st.Range("d4:h500").ClearContents
         Set mh = reg.Execute(sn)
         cn = mh(0)
         m = 4
   For j = 1 To UBound(ar)
     Sql = "Select 影片,上映时间,[挂牌价(元)],[渠道结算价(元)],已出售票数 from [数据$] Where 影院 = '" & cn & "' and 影厅编号 = '" & ar(j - 1) & " '"
     Set Rst = Conn.Execute(Sql)
     With Sheets(sn)
       .Cells(m, 4).CopyFromRecordset Rst
        m = m + 10
     End With
   Next
  End If
  
Next
Application.ScreenUpdating = True
End Sub

05050818

Sub 分配()
Application.ScreenUpdating = False
Dim Conn As Object, Rst As Object
Dim strConn As String, strSQL As String
Dim i As Integer, PathStr As String

Set Conn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")

PathStr = ThisWorkbook.FullName
Select Case Application.Version * 1
    Case Is <= 11
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    Case Is >= 12
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
End Select
Conn.Open strConn
Set reg = CreateObject("VbScript.RegExp")
reg.Pattern = "\W+"
Set d = CreateObject("Scripting.Dictionary")
Set sh = Sheets("数据")
With sh
  r = .Cells(.Rows.Count, 1).End(3).Row
     For i = 2 To r
       d(.Cells(i, 4).Value) = ""
     Next
       ar = d.keys
End With



For Each st In Sheets
  If st.Name <> "数据" Then
         sn = st.Name
         st.Range("d4:h500").ClearContents
         Set mh = reg.Execute(sn)
         cn = mh(0)
         m = 4
   For j = 1 To UBound(ar)
     Sql = "Select 影片,上映时间,[挂牌价(元)],[渠道结算价(元)],已出售票数 from [数据$] Where 影院 = '" & cn & "' and 影厅编号 = '" & ar(j - 1) & " '"
     Set Rst = Conn.Execute(Sql)
     With Sheets(sn)
       .Cells(m, 4).CopyFromRecordset Rst
        m = m + 10
     End With
   Next
  End If
  
Next
Application.ScreenUpdating = True
End Sub

opiona

69楼：http://club.excelhome.net/thread-1409141-1-1.html

harryfooty

05050818 发表于 2019-1-23 18:52
Sub 分配()
Application.ScreenUpdating = False
Dim Conn As Object, Rst As Object

大神！太强大了！等下我有赞来点赞！现在就是想保留整个分表有内容的部分，可以做到吗？
我加了个模块把分表复制的数据的单元格都清空掉了想着来测试；但是我使用你的代码时总说我有合并区域，无法清除内容。这里是报错的地方。

错误位置1

错误说明1

最后就是想大神帮忙修改一下，代码能在这使用，保留分表的其他内容！请大神指教~

05050818

st.Range("d4:h500").ClearContents  改成 st.Range("d6:h500").ClearContents
m=4 改在 m=6
因为你的分表格式不统一，我删掉了第一个分表（新余抱石)的部分单元格，操持格式统一

harryfooty

05050818 发表于 2019-1-25 08:50
st.Range("d4:h500").ClearContents  改成 st.Range("d6:h500").ClearContents
m=4 改在 m=6
因为你的分 ...

是的，后来我看懂了！后面加上了两个隐藏的表格，让它不要删除！然后还加入了增加行和删除行的代码，（昨天发现我的数据可能会到11行，应该是最大的了）我的原始表格是都适用的！大神你太强大了！再次点赞！好奇怪，我附件上传不上来了。。

harryfooty

05050818 发表于 2019-1-25 08:50
st.Range("d4:h500").ClearContents  改成 st.Range("d6:h500").ClearContents
m=4 改在 m=6
因为你的分 ...

大神能否延伸一下，总数据里加入了一列日期包括（2019-2-5、2019-2-6、2019-2-7），能否根据日期来把总数据复制到分表对应的列的位置 大神能否帮忙在这个“分配数据测试2”模块里帮忙修改一下。

我想到的是用字典先把2月5、6、7日的列数先记住，然后复制的时候再复制到对应的列号里。但是一个程序能用两个字典吗？