将特定内容从一个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个单元格（即从站点到所有部分转移），内容应该被复制到新创建的工作簿的第一张（名为Header Sheet），而对于第10行之后的其他数据（即表数据）我只想在工作簿的单独表（详细信息表）中的新工作簿中的特定列（即我希望存在10/19列）。

以下是我在新工作簿中想要数据的快照。

在上面的图片中，我想要Header Tab中的前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