Question

VB如何从一个excel表复制内容到另外一个表中

Private Sub Command1_Click()
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim oSheet As New Excel.Worksheet
Dim Copygene As String
Dim Copyright As String
Dim Copyzuobiao As String
Dim zuobiaoright As String
Dim i As Integer, j As Integer
On Error Resume Next

CommonDialog1.DefaultExt = "xls"
CommonDialog1.FileName = "数据导出"
CommonDialog1.Filter = "工作表文件(*.xls)"
CommonDialog1.DialogTitle = "另存为EXCEL"
CommonDialog1.InitDir = App.Path
CommonDialog1.ShowSave
CommonDialog1.Flags = cdlOFNOverwritePrompt
'----------------------------------------
On Error Resume Next
Dim myexcel As New Excel.Application
Dim mybook As New Excel.Workbook
Dim mysheet As New Excel.Worksheet
myexcel.Visible = False
Set mybook = myexcel.Workbooks.Add
Set mysheet = mybook.Worksheets(1)
'mysheet.Range("E1") = "A"
'Copygene = mysheet.Range("E1")

For i = 0 To File1.ListCount - 1
Set xlBook = xlApp.Workbooks.Open(File1.Path & "\" & File1.List(i))
Copygene = mysheet.Range("A1")
xlApp.Visible = False
Set oSheet = xlBook.Worksheets(1)

' oSheet.Range("A1").Copy mysheet.Range("A1").Offset(0, i)
mysheet.Range("A1").Offset(0, i) = oSheet.Range("A1")
Copygene = mysheet.Range("A1")
Copygene = mysheet.Range("E1")
Set oSheet = Nothing '释放sheet对象
xlBook.Close '关闭文件
Set xlBook = Nothing
' xlApp.Quit '关闭Excel
' Set xlApp = Nothing
Next i

mybook.SaveAs CommonDialog1.FileName
mybook.Close
myexcel.Quit
xlApp.Quit '关闭Excel
Set xlApp = Nothing
Set mysheet = Nothing
Set mybook = Nothing
Set myexcel = Nothing
end sub

我想要把一个文件夹里面的excel表内容的指定部分都复制到一个新建的excel中保存。调试的时候发现我无法使用copy的方式复制，用A=B的方式倒是可以，不过我需要复制的单元格太多，一个个单元格复制效率太低。
请问大家我的代码是哪里出了问题，需要如何解决这个问题？

Answer 1

1.如图，将单元格区域复制，并粘贴到另外的区域，很明显，粘贴后并没有所有的格式复制过来。特别是行高列宽。要重新调整很麻烦。

2.其在粘贴选项里选择保持“保留源列宽”就可以了。

3.第二种方法是选择性粘贴的方法，
点鼠标右键→“选择性粘贴”命令，在对话框中选择“列宽”。

4.复制单元格保留单元格行高和列宽
整行复制可以保留行高，整列复制可以保留列宽，都要保留就只有整表复制。
要同时选择区域所在的行和列

Answer 2

你可以 直接录制个宏，就可以了

追问

我试过，按照宏上面的方式还是不行。
oSheet.Activate
oSheet.Columns("A:C").Copy
Selection.Copy
mysheet.Activate
mysheet.Range("A1").Paste
我不知道是不是我改的osheet和mysheet的问题。

追答

Sub 复制()
Columns("A:C").Select
Selection.Copy
ActiveSheet.Paste
Columns("A:C").Select
Application.CutCopyMode = False
ChDir "C:\Users\YD00387\Desktop\新建文件夹"
ActiveWorkbook.SaveAs Filename:="C:\Users\YD00387\Desktop\新建文件夹\456.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("123.xls").Activate
End Sub
将桌面上 新建文件 这个文件夹里，1个一个名字为 123表的A:C列，复制到 新建表的A:C列，且重命名为 456

追问

参考你的代码出来的结果是这样的。

追答

什么情况？

追问

就是没复制过去啊

追答

在同一个文件夹里，打开需要复制的表，和一个空白的表，在需要复制的表里，录制宏，就好了，试下。