復制一行中的特定單元格一定次數，然后移動到行中的下一個單元格並在 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