复制一行中的特定单元格一定次数，然后移动到行中的下一个单元格并在 VBA 中复制相同的次数

Question

我对 VBA 比较陌生，我正在尝试将数据从一个工作簿移动到另一个工作簿。 具体来说，我正在尝试从可以使用我拥有的代码选择的第一个工作簿中移动行元素，并以特定方式将其移动到 Book1。 我当前的目标是从所选文件的第 3 行移动元素并将该行的每个单元格向下复制 358 次列 C 然后移动到该行中的下一个单元格并将其复制 358 次。 该行包含 62 个元素，每个元素都必须向下复制 358 次。 该行从第 2 列开始。

我正在使用的代码是：

Dim SelectedBook As Workbook
Dim lastRow As String
Dim i As Long
Dim j As Long
Dim n As Long

i = 1
j = 1
n = 2

FileToOpen = Application.GetOpenFilename(Filefilter:="Excel Files (*.xls*), *.xls*", Title:="Select FIles")

Do While n <= 62
    Do While j <= 358

        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        Cells(3, n).Select
        Selection.Copy
        Windows("Book1").Activate
        lastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1
        Range("C" & lastRow).Select
        Selection.PasteSpecial
        ActiveSheet.Paste
        j = j + 1
        Loop
        j = 1
        n = n + 1
        Loop

End Sub

复制发生了，但因为它是逐个细胞地发生的，所以它会永远发生，因为有太多的细胞和重复。 有没有办法以使其运行得更快的方式加快速度？ 任何帮助将不胜感激，在此先感谢！

Answer 1

重复转置标头

• 它将打开所选文件并将数据复制到新创建的单工作表工作簿。 首先，按原样进行测试并调整数字。 如果您有前面的代码未在此处发布，请将创建工作簿的行移动到代码的开头，并使用dwb （和dws ）而不是（激活） Windows("Book1") 。

Sub TransposeHeaders()
     
    Const dReps As Long = 358

    ' Open the source file.
    Dim sPath: sPath = Application.GetOpenFilename( _
        Filefilter:="Excel Files (*.xls*), *.xls*", Title:="Select FIles")
    If VarType(sPath) = vbBoolean Then
        MsgBox "No file selected.", vbExclamation
        Exit Sub
    End If

    ' Write the values from the source worksheet to the source array.
    Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
    Dim sws As Worksheet: Set sws = swb.Worksheets(1) ' adjust e.g. "Sheet1"
    Dim srg As Range
    Set srg = sws.Range("B3", sws.Cells(3, sws.Columns.Count).End(xlToLeft))
    Dim sData(): sData = srg.Value
    
    ' Write the values from the source to the destination array.
    
    Dim scCount As Long: scCount = srg.Columns.Count
    Dim dData(): ReDim dData(1 To scCount * dReps, 1 To 1)
    
    Dim sValue, sc As Long, dRep As Long, dr As Long
    
    For sc = 1 To scCount
        sValue = sData(1, sc)
        For dRep = 1 To dReps
            dr = dr + 1
            dData(dr, 1) = sValue
        Next dRep
    Next sc
    
    ' Write the values from the destination array to the destination range.
    
    ' Add and reference a new single-worksheet workbook.
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
    ' Reference its only worksheet.
    Dim dws As Worksheet: Set dws = dwb.Sheets(1) ' the one and only
    ' Reference the destination range.
    Dim dfCell As Range: Set dfCell = dws.Range("C2")
    Dim drg As Range: Set drg = dfCell.Resize(dr)
    ' Write the values from the destination array to the destination range.
    drg.Value = dData
    
    ' Close the source workbook.
    swb.Close SaveChanges:=False

End Sub

Answer 2

下面是一些注释代码，可以帮助您了解如何编写您要查找的内容：

Sub ImportData()
    
    'Import data from StartCol to FinalCol, from CopyRow, a total of CopyTimes
    Const sStartCol As String = "B"
    Const sFinalCol As String = "BK"
    Const lCopyRow As Long = 3
    Const lCopyTimes As Long = 358
    
    'Data imported will be placed in DestCol
    Const sDestCol As String = "C"
    
    'Option to clear previous data before importing
    'Set this to false if you want to keep prior data
    Const bClearPrevious As Boolean = True
    
    'Declare and define destination variables
    Dim wbDest As Workbook:     Set wbDest = ThisWorkbook
    Dim wsDest As Worksheet:    Set wsDest = wbDest.Worksheets("Sheet1")    'Set this to correct worksheet in destination workbook
    
    'Prompt for source file
    Dim sSourceFile As String
    sSourceFile = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "Select Import File", MultiSelect:=False)
    If sSourceFile = "False" Then Exit Sub  'Pressed cancel
    
    'Clear previous results if option is set to true
    If bClearPrevious = True Then wsDest.Range(sDestCol & 2, wsDest.Cells(wsDest.Rows.Count, sDestCol).End(xlUp)).ClearContents
    
    Dim lColIndex As Long
    Dim sSourceSheet as String
    With Workbooks.Open(sSourceFile)
        'Specify correct worksheet for the source workbook names here
        Select Case .Name
            Case "Book1.xlsx": sSourceSheet = "Sheet1"
            Case "Book2.xlsx": sSourceSheet = "Sheet10"
            Case "Book3.xlsx", "Book4.xlsx": sSourceSheet = "DataSheet"
            Case Else: sSourceSheet = "Sheet1" 'If the other cases aren't found, it will default to the Case Else
        End Select
        With .Worksheets(sSourceSheet)
        
            For lColIndex = .Columns(sStartCol).Column To .Columns(sFinalCol).Column
                wsDest.Cells(wsDest.Rows.Count, sDestCol).End(xlUp).Offset(1).Resize(lCopyTimes).Value = .Cells(lCopyRow, lColIndex).Value
            Next lColIndex
            
        End With
        .Close False    'Close source file, don't save changes
    End With
    
End Sub