Excel中利用VBA实现类似「邮件合并」注：（自己写的代码无法运行，跪求大佬帮忙）

wuqing960412

Excel中利用VBA实现类似word的「邮件合并」   

把对应的数据放到模板中去（附件中模板标注颜色的都需要从数据中提取），以唯一的宗地代码生成多个工作表。并以宗地代码命名工作表。




代码无法运行,运行出现问题，跪求大佬解答代码。

3190496160

具体描述你的需求，只是看你目前的代码，是不可能真正了解你的需求的，再者，也没有人原因义务帮你还得伤精费神其研究半天你的代码的

wuqing960412

3190496160 发表于 2023-2-10 09:49
具体描述你的需求，只是看你目前的代码，是不可能真正了解你的需求的，再者，也没有人原因义务帮你还得伤精 ...

Excel中利用VBA实现类似word的「邮件合并」   把对应的数据放到模板中去（附件中模板标注颜色的都需要从数据中提取），以唯一的宗地代码生成多个工作表。并以宗地代码命名工作表

半百

wuqing960412

半百 发表于 2023-2-10 10:40

感谢大佬帮忙，我想问下我写的无法运行，大佬能帮忙解答以下嘛？

半百

wuqing960412 发表于 2023-2-10 11:15
感谢大佬帮忙，我想问下我写的无法运行，大佬能帮忙解答以下嘛？

因为你表中有多个半成品过程 “CopyTheData”，保留一个就行了，就是有给单元格赋值语句的那个。
另外，N = Sheets("数据").UsedRange.Rows.Count - 1，因为已用区域（UsedRange）包含空白行，所以循环到空白行时代码会出错，就是无法给新增的工作表命名。

wuqing960412

跪求大佬解答

wxxydl

我给你做了一个  看一下   是这意思吗？

wxxydl

Sub 生成表()
      Application.ScreenUpdating = False
      Dim dic As Object, arr, i, j
      Set dic = CreateObject("scripting.dictionary")
      arr = Sheets("数据").UsedRange
      For i = 2 To UBound(arr)
            If Len(arr(i, 3)) Then
                  If Not dic.exists(arr(i, 3)) Then
                        Set dic(arr(i, 3)) = CreateObject("scripting.dictionary")
                        For j = 1 To UBound(arr, 2)
                              dic(arr(i, 3))(arr(1, j)) = arr(i, j)
                        Next
                  End If
            End If
      Next
      Set Rng = Sheets("模板").UsedRange
      Rng.Copy
      brr = Sheets("模板").UsedRange
      For Each ikey In dic.keys
            Sheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = ikey
            For i = 2 To UBound(brr)
                  For j = 1 To 10 Step 2
                        If dic(ikey).exists(brr(i, j)) Then
                              brr(i, j + 1) = dic(ikey)(brr(i, j))
                        End If
                  Next
            Next
            With ActiveSheet.[a1].Resize(UBound(brr), UBound(brr, 2))
                  .Value = brr
                  .PasteSpecial xlPasteFormats
                  .PasteSpecial xlPasteColumnWidths
                  
            End With
      Next
      Application.ScreenUpdating = True
End Sub
Sub 删除()
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      For Each sht In Worksheets
            If sht.Name <> "数据" And sht.Name <> "模板" Then sht.Delete
      Next
      Application.DisplayAlerts = True
      Application.ScreenUpdating = True
End Sub

wuqing960412

wxxydl 发表于 2023-2-10 21:36
Sub 生成表()
      Application.ScreenUpdating = False
      Dim dic As Object, arr, i, j

谢谢大佬谢谢大佬谢谢大佬