将特定内容从一个excel工作簿复制到另一工作簿

Question

我是VB的新手，正在开发一个VB脚本，该脚本将使用输入的excel文件并将其转换为另一个excel文件（新的Excel文件）。

我创建了一个宏文件，该文件将接收并输入文件，并创建一个与原始文件完全相同的新excel文件，但是具有新名称并位于给定位置。

将J3转换为阶段1按钮会将所选的excel工作簿转换为具有相同内容的新工作簿。

到目前为止，这是我的代码。 抱歉，如果不遵循编码标准，因为我是VB的新手。

Sub convertJ3ToPhase1()
j3ExcelSheet = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls*),*.xls*", Title:="Open Database File")
Dim SourceFile, DestinationFile
SourceFile = j3ExcelSheet
DestinationFile = "C:\Test\ABC.xlsx" ' Define target file name.
FileCopy SourceFile, DestinationFile ' Copy source to target.
End Sub

ABC.xlsx包含与原始excel工作簿相同的数据。

但是我的要求是不同的。

这是我的原始Excel文件

现在我想要的是从第一个单元格到第9个单元格（即从站点到所有部分传输），将内容复制到新创建的工作簿的第一个表（名为页眉表），而对于第10行之后的其他数据（即表数据） ）我只希望新工作簿中的特定列（即，我希望存在10/19列），而工作簿的单独工作表（详细信息表）中也是如此。

这是我如何在新工作簿中获取数据的快照。

在上图中，我想要“标题”选项卡中的前9行数据

在第二张（详细信息表）中，我只希望原始工作簿中的特定列。

因为我对VB脚本的语法和方法不了解太多，所以有人可以帮助我编写VB脚本吗？

Answer 1

这样的事情怎么样，您将不得不在代码中更改一些变量以匹配工作表的名称，等等：

Sub BrowseForJ3File()
Dim x As Workbook
    j3ExcelSheet = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls*),*.xls*", Title:="Open Excel File")
    If fileToOpen <> False Then
        MsgBox "Open " & fileToOpen
    End If

    ActiveSheet.Range("H9") = j3ExcelSheet

    Pos = InStrRev(j3ExcelSheet, "\")
    Filename = Mid(j3ExcelSheet, Pos + 1)
    'above get the filename

    Pos = InStrRev(Filename, ".")
    Extension = Mid(Filename, Pos + 1)
    'above get the extension

    Savepath = "C:\Users\Me\Desktop\"
    'get the path to save the new file

    NewFilename = "New Report"
    'above new filename

    Application.DisplayAlerts = False
    SheetName = "Sheet1" 'change this to the original Sheet Name

    Set x = Workbooks.Open(j3ExcelSheet)
    With x
        x.Sheets(SheetName).Range("A1:B9").Copy 'copy range to paste headers
        x.Sheets.Add().Name = "Header" 'add sheet Header
        x.Sheets("Header").Paste 'paste the copied range
        x.Sheets.Add().Name = "Detail" 'add details sheet
        LastRow = x.Sheets(SheetName).Cells(x.Sheets(SheetName).Rows.Count, "A").End(xlUp).Row 'get the last row with data from original sheet
        x.Sheets(SheetName).Range("A11:Q" & LastRow).Copy 'copy range
        x.Sheets("Detail").Paste 'paste into Detail
        x.Sheets("Detail").Range("D:D,F:N").Select 'select columns to delete
        Selection.Delete Shift:=xlToLeft
        x.Sheets(SheetName).Delete 'delete original Sheet

        .SaveAs Savepath & NewFilename & "." & Extension 'save with new name
        .Close
    End With
    Application.DisplayAlerts = True
 End Sub