查看: 339|回复: 12
大神，求助 ，将sheet1中数据复制到sheet2，并判重
阅读权限10
在线时间 小时
将“当天数据”中B2：N225中的数据复制到“历史数据库”A至M列中（累积添加，不覆盖已有数据）。
1、使用“当天数据”中E列的序号对比“历史数据库”中D列是否有相同的序号，有的话则报错，终止宏，并提示“存在重复数据不允许复制，请检查”
2、复制成功后，清空“当天数据”中B2：N225中数据
19:31 上传
点击文件名下载附件
39.6 KB, 下载次数: 8
阅读权限10
在线时间 小时
各位大神帮帮忙！
阅读权限100
在线时间 小时
建议认真准备求助的表格附件。提供部分模拟数据。
表头中有2个序号？
你的问题很简单的，很多人都可以解决。
阅读权限10
在线时间 小时
建议认真准备求助的表格附件。提供部分模拟数据。
表头中有2个序号？
你的问题很简单的，很多人都可以解 ...
谢谢老师提醒，万分感谢。已更新了一下数据。
11:21 上传
点击文件名下载附件
48.66 KB, 下载次数: 8
阅读权限10
在线时间 小时
求大神帮忙设计一下
阅读权限20
在线时间 小时
本帖最后由 绝版剩男 于
13:15 编辑
Sub aa()
n1 = &当天数据&
N2 = &历史数据库&
ENDROW1 = Sheets(n1).Cells(Rows.Count, 1).End(xlUp).Row
endrow2 = Sheets(n2).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To ENDROW1
& &For j = 2 To endrow2
& &If Sheets(n1).Cells(i, 5) = Sheets(N2).Cells(j, 4) Then
& && &Sheets(n1).Cells(i, 5).Interior.Color = 255
& && &MsgBox Sheets(n1).Cells(i, 5) & &出现重复，请修改！&
& && &Exit Sub
& &End If
& &Next j
Next i
& & Sheets(n1).Range(&B2:N& & ENDROW1).Copy
& & Sheets(n2).Select
& & Range(&A& & ENDROW2 + 1).Select
& & ActiveSheet.Paste
& & Sheets(n1).Range(&A2:N& & ENDROW1).ClearContents
& & Application.CutCopyMode = False
End Sub
复制代码
阅读权限20
在线时间 小时
看看 初测了下，能用。
阅读权限20
在线时间 小时
见附件，比较清晰
10:45 上传
点击文件名下载附件
51.75 KB, 下载次数: 7
阅读权限10
在线时间 小时
见附件，比较清晰
谢谢大神！
试用了一下，还有一个问题：
就是最后复制过去的时候会把原来的历史数据覆盖掉，应该不断累加才对，麻烦大神再帮忙看一下
阅读权限20
在线时间 小时
本帖最后由 绝版剩男 于
13:16 编辑
Range(&A& & ENDROW1 + 1).Select&&改成&&Range(&A& & ENDROW2 + 1).Select
手误，出现了错误，希望没有给你造成损失
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师请教，在Excel VBA中，如何将工作簿1的Sheet1 拷贝到工作簿2中？谢谢。_百度知道
请教，在Excel VBA中，如何将工作簿1的Sheet1 拷贝到工作簿2中？谢谢。
提问者采纳
Workbooks(&quot.Copy&B);aaa&1.Sheets(&).xlsx&):=Workbooks(& 2;SHEETS复制到 &AAA &nbsp.XLSX 这个表的 &nbsp，代码如下.xlsx&quot.xlsx 中;2比如把1
提问者评价
非常感谢。
来自团队：
其他类似问题
SSheet1&quot.Select
ActiveS);Sheet2&quot.Select
Cells.Copy
Sheets(&)Sub Macro1()
Sheets(&quot
来自团队：
为您推荐：
excel的相关知识
其他1条回答
录制一个宏
等待您来回答
下载知道APP
随时随地咨询
出门在外也不愁查看: 4022|回复: 31
引用多个分表数据到一张总表中，并能实现分表数据更新后总表自动更新
阅读权限10
在线时间 小时
本帖最后由 liusiqin 于
14:10 编辑
各位大神，请帮忙解决下，急求，谢谢！谢谢！
现在有几张分表，都单独在一个工作簿中，结构都是固定的几项
有1张总表，结构和分表一样，只多了一栏备注。
问题1：需要将3张分表的内容引用到总表中，并且能实现分表数据更新或修改，总表也自动更新。
问题2：总表的备注栏自动引用分表中最后一次时间和状态描述的内容，并一起显示在“备注”这一个单元格里。问题3 :如果新增加一张工作表，新增加的工作表内容也能被引用吗？
问题4：如果把总表和分表都同时放在一个工作簿中，是不是更容易操作？
(14.97 KB, 下载次数: 113)
14:10 上传
点击文件名下载附件
阅读权限50
在线时间 小时
请测试》》
Sub ado()&&'by feiren228
& & Application.ScreenUpdating = False
& & Dim cnn As Object, rs As Object, sql$, file As Object
& & Set fso = CreateObject(&Scripting.FileSystemObject&)
& & Set cnn = CreateObject(&Adodb.Connection&)
& & Set rs = CreateObject(&adodb.recordset&)
& & Sheets(&sheet1&).Range(&a2:z65535&).ClearContents
& & If Application.Version * 1 &= 11 Then
& && &&&cnn.Open &Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;hdr=no';Data Source=& & ThisWorkbook.FullName
& & Else
& && &&&cnn.Open &Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=no';Data Source=& & ThisWorkbook.FullName
& & End If
& & For Each file In fso.GetFolder(ThisWorkbook.Path & &\&).Files
& && &&&If file.Name Like &*.xls& And file.Name && ThisWorkbook.Name Then
& && && && &sql = &select * from [Excel 8.0;imex=1;hdr=Database=& & file & &].[sheet1$A2:I] where f1 is not null&
& && && && &Set rs = cnn.Execute(sql)
& && && && &Sheets(&sheet1&).Range(&a& & Sheets(&sheet1&).Cells(Rows.Count, 1).End(3).Row + 1).CopyFromRecordset rs
& && &&&End If
& & Next
& & rs.Close
& & cnn.Close
& & Set rs = Nothing
& & Set cnn = Nothing
& & With Sheets(&sheet1&)
& && &&&r = .Cells.Find(&*&, Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算最后一个工作表的非空行号
& && &&&col = .Cells.Find(&*&, Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column '计算最后一个工作表的非空列号
& && &&&arr = .[a2].Resize(r - 1, col)
& && &&&ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
& && &&&Dim bz As Boolean
& && &&&For i = 1 To UBound(arr)
& && && && &bz = False
& && && && &For j = UBound(arr, 2) To 1 Step -1
& && && && && & If j &= 3 Then
& && && && && && &&&brr(i, j) = arr(i, j)
& && && && && & Else
& && && && && && &&&If bz Then GoTo 100
& && && && && && &&&Select Case j
& && && && && && &&&Case 8
& && && && && && && && &If Len(arr(i, j)) & 0 Then brr(i, 4) = arr(i, j) & &|& & arr(i, j + 1): bz = True
& && && && && && &&&Case 6
& && && && && && && && &If Len(arr(i, j)) & 0 Then brr(i, 4) = arr(i, j) & &|& & arr(i, j + 1): bz = True
& && && && && && &&&Case 4
& && && && && && && && &If Len(arr(i, j)) & 0 Then brr(i, 4) = arr(i, j) & &|& & arr(i, j + 1): bz = True
& && && && && && &&&End Select
& && && && && & End If
100:
& && && && &Next j
& && &&&Next i
& && &&&.[a2].Resize(UBound(brr), UBound(brr, 2)) = brr
& & End With
& & Application.ScreenUpdating = True
End Sub
复制代码
阅读权限50
在线时间 小时
附件》》》
(27.44 KB, 下载次数: 216)
09:27 上传
点击文件名下载附件
阅读权限10
在线时间 小时
非常感谢feiren228 两个问题都解决了 我再根据具体内容研究下&&真是太感谢了！！！
阅读权限95
在线时间 小时
& & Dim f$, p$, a
& & Application.ScreenUpdating = False
& & p = ThisWorkbook.Path & &\&
& & f = Dir(p & &*.xls&)
& & Sheet1.[a2:d1000].ClearContents
& & Do While Len(f)
& && &&&If f && ThisWorkbook.Name Then
& && && && &With GetObject(p & f)
& && && && && & a = .Sheets(1).Range(&A2:I& & .Sheets(1).[a65536].End(3).Row)
& && && && && & .Close
& && && && &End With
& && && && &Sheet1.Range(&A& & Sheet1.[a65536].End(3).Row + 1).Resize(UBound(a), UBound(a, 2)) = a
& && &&&End If
& && &&&f = Dir
& & With Sheet1
& && &&&For i = 2 To .[a65536].End(3).Row
& && && && &Set c = .Range(&IV& & i).End(xlToLeft)
& && && && &.Cells(i, 4) = c.Offset(0, -1) & &&&& & c
& && &&&Next
& && &&&.[e:s] = &&
& & End With
& & Application.ScreenUpdating = True
阅读权限95
在线时间 小时
&&&&&&&&&&&&&&&&&&&&&&
(21.81 KB, 下载次数: 147)
10:26 上传
点击文件名下载附件
阅读权限70
在线时间 小时
代码放在总表中：
Private Sub CommandButton1_Click()
Dim Arr, Brr, Crr, i, j, k
Dim MyPath$, MyName$, m&, sh As Worksheet
Application.ScreenUpdating = False
On Error Resume Next
Set sh = ActiveSheet
MyPath = ThisWorkbook.Path & &\&
MyName = Dir(MyPath & &*.xls&)
sh.Range(&A2:D65536&).Clear
Do While MyName && &&
& &If MyName && ThisWorkbook.Name Then
& && &With GetObject(MyPath & MyName)
& && && &&&Arr = .Sheets(&sheet1&).Range(&A1&).CurrentRegion
& && && &&&ReDim Brr(1 To UBound(Arr) - 1, 1 To 4)
& && && &&&For i = 2 To UBound(Arr)
& && && && && &For j = 1 To UBound(Arr, 2)
& && && && && && & If j &= 3 Then
& && && && && && && & Brr(i - 1, j) = Arr(i, j)
& && && && && && & Else
& && && && && && && & If Arr(i, j) = && Then
& && && && && && && && & Brr(i - 1, 4) = &时间：& & Arr(i, j - 2) & &，状态：& & Arr(i, j - 1)
& && && && && && && && & Exit For
& && && && && && && & End If
& && && && && && & End If
& && && && && &Next
& && && &&&Next
& && && &&&sh.Range(&A65536&).End(xlUp).Offset(1).Resize(UBound(Brr), UBound(Brr, 2)) = Brr
& && && &&&.Close False
& && &End With
& &MyName = Dir
Application.ScreenUpdating = True
阅读权限70
在线时间 小时
(24.6 KB, 下载次数: 72)
10:34 上传
点击文件名下载附件
阅读权限10
在线时间 小时
feiren228 发表于
附件》》》
我试图在你的代码基础上做修改&&引用到具体的内容里&&但是出现了很多问题&&道行太浅&&解决不了啊 能不能在之前的基础上帮我再修改下&&我重新传一份附件&&谢谢！
(14.97 KB, 下载次数: 20)
13:29 上传
点击文件名下载附件
或者把总表和分表都放在同一个工作簿里面去会不会更方便操作？谢谢！
阅读权限10
在线时间 小时
aman1516 发表于
是可以的，谢谢！但是我在复制到具体的内容中运行时，修改了下就运行不起了，能不能在新的附件中再帮我修改下？谢谢！
(14.97 KB, 下载次数: 17)
13:47 上传
点击文件名下载附件
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师vba中怎样表示一个sheet？_百度知道
vba中怎样表示一个sheet？
vba中 用sheet1,2,3来表示是不保险的，如果将sheet1删除再创建一个表单后，新表单默认叫sheet4，再在VBA中调用sheet1就会出错。请用下面过程选中需要表单：Sub 遍历工作表()
Dim a As String, n As Integer
For n = 1 To Worksheets.Count
a = Sheets(n).Name
Sheets(n).Select
'当然这里可加上判断语句，根据需要选中sheet
Next nEnd Sub
其他类似问题
为您推荐：
提问者采纳
n As Integer
For n = 1 To Worksheets.Count
a = Sheets(n).Select
&#39，新表单默认叫sheet4,3来表示是不保险的用sheet1，如果将sheet1删除再创建一个表单后;当然这里可加上判断语句,2：Sub 遍历工作表()
Dim a As String。请用下面过程选中需要表单，再在VBA中调用sheet1就会出错.Name
vba的相关知识
其他1条回答
sheet1.select完全可以，只是程序解读的时候有点晕
等待您来回答
下载知道APP
随时随地咨询
出门在外也不愁查看: 182|回复: 2
根据 1.xlsx 中 sheet1中的内容，删除当前工作薄中的工作表
阅读权限10
在线时间 小时
本帖最后由 suishuhao 于
17:34 编辑
当前工作薄有27个工作表。
1.xlsx 中 sheet1中有一列工作表名，共18行。
如果当前工作薄中的工作表名称不存在于1.xlsx 中 sheet1中，那么就将其删除。程序如下：
Sub mysub()
Dim i As Integer
Dim j As Integer
Dim flag As Integer
For j = 1 To Sheets.Count
For i = 1 To 18
If Workbooks(&大武3万以下.xls&).Sheets(j).Name = Workbooks(&1.xlsx&).Sheets(1).Cells(i, 1) Then
If flag = 0 Then
Workbooks(&大武3万以下.xls&).Sheets(j).Delete
运行一段时间，删除了几个工作表后就提示越界，结束后再运行，又删除了几个工作表然后又提示越界，结束程序后再次运行，又删除了几个工作表，才实现。
什么毛病啊？不过折腾了3次，最后运行结果还是对的
17:20 上传
点击文件名下载附件
6.82 KB, 下载次数: 2
17:20 上传
点击文件名下载附件
11.42 KB, 下载次数: 2
阅读权限95
在线时间 小时
Sub DelSht()
& & Dim dicSht As Object
& & Dim Wb As Workbook
& & Dim Sht As Worksheet
& & Dim arrInfo As Variant
& & Dim i As Integer
& &
& & Application.DisplayAlerts = False
& & Set dicSht = CreateObject(&scripting.dictionary&)
& & Set Wb = Workbooks.Open(ThisWorkbook.Path & &\1.xlsx&)
& & With Wb.Sheets(1)
& && &&&arrInfo = .Range(.Cells(1, &A&), .Cells(Rows.Count, &A&).End(3))
& & End With
& & For i = 1 To UBound(arrInfo, 1)
& && &&&dicSht(arrInfo(i, 1)) = &&
& & Next
& & Wb.Close
& & Set Wb = Nothing
& & For Each Sht In Worksheets
& && &&&If Not (dicSht.exists(Sht.Name)) Then
& && && && &Sht.Delete
& && &&&End If
& & Next
& & Application.DisplayAlerts = True
& &
End Sub复制代码
阅读权限10
在线时间 小时
本帖最后由 suishuhao 于
20:32 编辑
毛病找到了：
每删除一个工作表时，此工作表后面的工作表的标识会暗中发生变化。
比如，第2个工作表被删除前，第三个工作表是sheets(3),但在第2个工作表被删除后，第三个工作表会由原先的sheet(3)自动变成sheets(2)，（但是其名称依然为sheet3)，其他以此类推。
这就导致了程序越界等等一系列问题
还有一点就是 工作表名是文本，所以 1.xlsx中的数据如果是数字，必须变成文本格式（即数字前加上撇号）
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师