Copying a specific cell in a row certain number of times and then moving to the next cell in the row and copying it the same number of times in VBA

Question

I'm relatively new to VBA and I'm trying to move data from one workbook to another. Specifically I'm trying to move row elements from the first workbook which can be selected using the code I have and move it to Book1 in a specific way. My current goal is to move elements from the 3rd row of the selected file and copy each cell of that row 358 times down column C and then move to the next cell in the row and copy it 358 times as well. The row contains 62 elements which each have to be copied 358 times down a column. The row starts from column 2.

The code I'm using is :

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

The copying happens but because it is happening cell by cell its taking forever due to there being so many cells and the repetition as well. Is there anyway to speed this up in such a way that it can run faster? Any help would be appreciated, thanks in advance!

Answer 1

Transpose Headers Repeatedly

• It will open the selected file and copy the data to a newly created single-worksheet workbook. First, test it as-is and adjust the numbers. If you have a preceding code not posted here, move the lines, creating the workbook, to the beginning of the code and use dwb (and dws) instead of (activating) 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

Here's some commented code that should help you understand how to write what you're looking for:

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