各位大神，如何用vba讲内容剪切粘贴到同个工作簿另一个工作表？_excel吧_百度贴吧
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&签到排名：今日本吧第个签到，本吧因你更精彩，明天继续来努力！
本吧签到人数：0成为超级会员，使用一键签到本月漏签0次！成为超级会员，赠送8张补签卡连续签到：天&&累计签到：天超级会员单次开通12个月以上，赠送连续签到卡3张
关注：87,745贴子：
各位大神，如何用vba讲内容剪切粘贴到同个工作簿另一个工作表？收藏
如图，如何将表中按渠道将内容剪切到不同工作表中，例如将渠道为HKCP大包空邮的内容剪切到sheet1，HKCP大包平邮的内容剪切到sheet2。因为我有几十个这种渠道，所以想用vba来完成这个功能感激不尽啊
Sub test()
Set dic = CreateObject("scripting.dictionary")
Set sht = ActiveSheet
n = Range("c65536").End(xlUp).Row - 1
arr = Range("c2").Resize(n, 1).Value
For r = 1 To n
dic(arr(r, 1)) = dic(arr(r, 1)) + 1
bt = Range("a1:g1").Value
sn = dic.keys
st = dic.items
On Error GoTo AddSheet
For i = 0 To UBound(sn)
With Sheets(sn(0))
Range("a1:g1").Value = bt
Range("a2").Resize(st(i), 7).Value = sht.Cells(r, 1).Resize(st(i), 7).Value
r = r + st(i)
Set dic = Nothing
Exit SubAddSheet:
Sheets.Add Sheets(1)
Sheets(1).Name = sn(i)
Resume Next
With Sheets(sn(0)) 应该改为
With Sheets(sn(i))另外，做之前要对C列进行排序
试了几次，在With下面的两句前加上点后，又在With前边加一个空的With【With Sheets(sn(i))
End With】（用来判断该表是否存在），然后就不会出错了，不论是否需新增工作表。
请问这个语句全部修改正确后应该怎么写，大家说的我没看明白？
请教一下几位前辈，如果需要同时对两列的内容进行分拆，应该如何修改代码？比如分离渠道再同时分离状态，单一渠道下的单一状态为一个工作表。是否需要找一个不用排序的思路？@zipall@青水蛙鸣@wangxf92099
其他的差不多，运行代码前，对渠道、状态进行排序把猫吧code中最上面这几行改下应该就行了。Set dic = CreateObject("scripting.dictionary")Set sht = ActiveSheetn = Range("c65536").End(xlUp).Row - 1arr = Range("c2").Resize(n, 5).ValueFor r = 1 To ndic(arr(r, 1)&“,"& arr(r,5)) = dic(arr(r, 1)&“,"& arr(r,5)) + 1Next没测试，你试试看有可以不用排序的，网上有相应的代码，一般是思路是字典取不重复的关键字，然后新建工作表，再从数组一条一条抽取赋 值 ，但这样速度会比猫吧那种慢很多。
@青水蛙鸣excellent!!很顺利，谢谢！另外代码可能还有处要完善。4楼的加空with具体的代码应该咋整？或者说应该如何防止同已有工作表重名的错误？
登录百度帐号推荐应用
为兴趣而生，贴吧更懂你。或新人请教各路大神一个关于excel VBA的问题，跪求给予帮助，该怎么改才能实现，谢谢。_百度知道
新人请教各路大神一个关于excel VBA的问题，跪求给予帮助，该怎么改才能实现，谢谢。
想做宏导入excel表数据批处理提示面第标注行：类型匹配几句注释掉提示第二标注行：类型匹配代码：跪求神指点迷津Sub 批处理()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
workbookname = ActiveWorkbook.Name()
CellFilename = Application.GetOpenFilename(&xls Files(*.xls),*.xls&, , &请选择打需要处理指标文件&, , True) 'If CellFilename = False Then
----行提示类型匹配'Exit Sub 'End If
Workbooks(workbookname).Sheets(1).Cells(2, 1) = Left(CellFilename, InStrRev(CellFilename, &\&))
----行提示类型匹配 For m = 1 To 9
If CellFilename && && Then
Workbooks.OpenText Filename:=CellFilenameIf CellFilename = &*6000*& Or CellFilename = &*6900*& Then【段处理程a】Else【段处理程b】End IfEnd IfNextApplication.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox &数据整理完毕&End Sub
提问者采纳
'If CellFilename = False Then
----行提示类型匹配, cellfilename类型字符串boolean类型值报错哥做HW设备网优吧 1给段代码仅供参考Dim tempv As IntegerDim sheetname As Stringexistflag = Falsefalsenum = 0i = 1
Application.DisplayAlerts = False
Application.CutCopyMode = False
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
MsgBox (&请输入要合并sheet名字&)
sheetname = InputBox(&输入要合并sheetname&)
If sheetname = && Then
MsgBox &输入sheet名字合&
inputfilename = Application.GetOpenFilename(&EXCEL文件(*.*.*.csv), *.*.*.csv&, , , , True) &#39;打支持2003<img class="word-replace" src="/api/getdecpic?picenc=0ad07.CSV文件
If Not IsArray(inputfilename) Then Exit Sub &#39;没选相关工作簿退程序
filenum = UBound(inputfilename)
Debug.Print (filenum)
tm = Timer
For openfilenum = 1 To filenum
excelfilename = CStr(dealfilename(inputfilename(openfilenum)))
Workbooks.Open (excelfilename)
existflag = SheetsExist(sheetname)
&#39;Debug.Print (&exist=& & existflag)
If (existflag) Then
Debug.Print (existflag)
Worksheets(sheetname).Activate
Rows(&2:& & ActiveSheet.UsedRange.Rows.Count).Select
Selection.Copy
ThisWorkbook.Worksheets(&合并数据&).Activate
&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;&#39;ThisWorkbook.Worksheets(&合并数据&).Cells(ThisWorkbook.Worksheets(&合并数据&).UsedRange.Rows(Column(1)).Count + 2, 1).Activate
While Not Cells(i, 1) = &&
ThisWorkbook.Worksheets(&合并数据&).Cells(i, 1).Activate
ActiveCell.PasteSpecial
Windows(excelfilename).Activate
ActiveWindow.Close
Application.StatusBar = &处理 & & excelfilename & & 请耐等待
处理第& & openfilenum & &文件&
Windows(excelfilename).Activate
ActiveWindow.Close
falsenum = falsenum + 1
&#39;Workbooks.Open (excelfilename)
&#39;existflag = SheetsExist(sheetname)
&#39;Worksheets(sheetname).Cells(1, 1).Activate
&#39;Rows(&1:1&).Select
&#39;Selection.Copy
&#39;Windows(&EXCEL文件合并.XLSM&).Activate
&#39;Worksheets(&合并数据&).Cells(1, 1).Activate
&#39;Rows(&1:1&).Select
&#39;Selection.Insert Shift:=xlDown
&#39;Windows(excelfilename).Activate
ActiveWindow.Close
If falsenum = 0 Then
MsgBox (&您共打& & openfilenum & &文件其& & falsenum & &文件包含您所输入SHEETNMAE!请核查输入文件名否确及所要合并文件格式否致&)
Application.StatusBar = &C程序执行已结束&
MsgBox (&程序运行间& & Format(Timer - tm & &秒 共处理& & filenum & &文件!&))
End SubFunction dealfilename(ByVal str As Variant) &#39;函数完态解文件名应该存更简介代码实现些功能Dim arr As StringDim j As Integer
j = 1Dim strlen As Integerstrlen = Len(str)Do While Not (Mid(str, strlen, 1) = &&#92;&)
strlen = strlen - 1
j = strlen
Loopdealfilename = Right(str, Len(str) - j)End FunctionFunction SheetsExist(wsName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(wsName)
On Error GoTo 0
SheetsExist = Not ws Is Nothing
Set ws = NothingEnd Function
提问者评价
其他类似问题
为您推荐：
您可能关注的推广
excel的相关知识
等待您来回答
下载知道APP
随时随地咨询
出门在外也不愁请教大神，如何用VBA生成一个Excel文件并命名呢_excel吧_百度贴吧
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&签到排名：今日本吧第个签到，本吧因你更精彩，明天继续来努力！
本吧签到人数：0成为超级会员，使用一键签到本月漏签0次！成为超级会员，赠送8张补签卡连续签到：天&&累计签到：天超级会员单次开通12个月以上，赠送连续签到卡3张
关注：87,745贴子：
请教大神，如何用VBA生成一个Excel文件并命名呢收藏
生成Excel的代码我知道。Dim gzb As Workbook
Set gzb = Workbooks.Add
gzb.SaveAs &E:\例子\mm.xls&
Set gzb = Nothing这样就在E盘的例子文件夹生成一个mm.xls的文件。现在我想这样：定义一个数组Array(&a&,&b&,&c&),然后运行程序就会在E:\例子生成a.xls,b.xls,c.xls三个文件。
套个for next循环arr = Array(&a&, &b&, &c&)
For i = 0 To UBound(arr)Set gzb = Workbooks.Addgzb.SaveAs &E:\例子\& & arr(i) & &.xls&Next
如果我的数组是这样定义的arr = Application.Transpose(Range(&A1:A3&))，即把现在表格中A1,A2,A3的值赋给数组，运行时就提示“下表越界”，请问这是为什么？
登录百度帐号推荐应用
为兴趣而生，贴吧更懂你。或请点击继续访问}