在 excel 中复制一列并将每个条目/单元格加倍。 如何？

Question

Let's say we have a row of elements, 1 per cell: 1,2,3,4. I want to copy this row(or column) and double every entry: 1,1,2,2,3,3,4,4.

Is there any formula, function, etc that does this? Thanks a lot.

I have about 20k entries so doing it manually is not an option.

Answer 1

For example:

Formula in F1 :

=INDEX($A1:$D1,1,ROUNDUP((COLUMN()-5)/2,0))

Drag right and down...

Answer 2

You could use:

Option Explicit

Sub test()

    Dim LastRow As Long, i As Long, j As Long, LastColumn1 As Long, LastColumn2 As Long, Add1 As Long, Add2 As Long
    Dim str As String

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow

            LastColumn1 = .Cells(i, .Columns.Count).End(xlToLeft).Column

            For j = 1 To LastColumn1

                LastColumn2 = .Cells(i, .Columns.Count).End(xlToLeft).Column

                If LastColumn2 = LastColumn1 Then
                    Add1 = 2
                    Add2 = 3
                Else
                    Add1 = 1
                    Add2 = 2
                End If

                .Range(.Cells(i, LastColumn2 + Add1), .Cells(i, LastColumn2 + Add2)).Value = .Cells(i, j).Value

            Next j

        Next i

    End With

End Sub

Results:

Answer 3

Formula:

Result:

Hold and drag along the rows

Answer 4

Easy alternative using the advanced possibilities of Application.Index()

This approach demonstrates the advanced restructuring possibilities of the ► Application.Index() function whose row and column arguments are fed by arrays instead of single numeric indices.

Main procedure RedoubleCols

This procedure executes two steps:

1. it assigns data to a 1-based 2-dim array v by one code line,
2. it restructures the complete array via Application.Index where the row and column arguments are arrays returned by helper functions AllRows() and RDC() ; the resulting array is written back to a given target.

Sub RedoubleCols(rng As Range, rng2 As Range)
' Purpose: get column values and write them back in pairs
' Param.:  1-rng: source range, 2-rng2: target range
' Method:  uses the advanced features of the Application.Index function
  Dim v                 ' declare variant (array)
' [1] get data
  v = rng.Value2
' [2] rearrange data by redoubling columns (RDC) and write them to a given target range
  rng2.Value2 = Application.Index(v, AllRows(UBound(v)), RDC(UBound(v, 2)))
End Sub

Helper functions used by main procedure above

Function AllRows(ByVal n&) As Variant
' Purpose: create transposed Array(1,2,...n)
Dim i&: ReDim tmp(n - 1)
For i = 0 To n - 1
    tmp(i) = i + 1
Next i
AllRows = Application.Transpose(tmp)
End Function

Function RDC(ByVal n&) As Variant()
' Purpose: create Array(1,1,2,2,...n,n) containing pairs of each column number
Dim i&: ReDim tmp(2 * n - 1)                  ' declare counter and zero based counter array
For i = 0 To n - 1                            ' redouble column counters
    tmp(i * 2) = i + 1
    tmp(i * 2 + 1) = i + 1
Next i
RDC = tmp                                     ' return counter array
End Function

Example Call

The essential code line in section [3] simply calls the main procedure RedoubleCols :

RedoubleCols src, target

where source range and target range can be defined following your needs - cf sections [1] and [2] .

Sub ExampleCall()
' [1] Identify source range
  Dim src As Range
  Set src = ThisWorkbook.Worksheets("MySheet").Range("A1:D2")
' [2] define any target, e.g. 1 column to the right of source data
  Dim target As Range, r&, c&
  r = src.Rows.Count: c = src.Columns.Count
  Set target = src.Offset(0, c + 1).Resize(r, c * 2)    ' reserve double space for columns
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' [3] write redoubled source range columns back to target
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  RedoubleCols src, target
End Sub

Recommended link

Treating Some peculiarities of the the Application.Index function

Answer 5

Assuming 1 is in A1 and you prefer rows.

To avoid dragging down for 20k entries I suggest in E1:

 =INDEX($A1:$D1,,INT((COLUMN()-3)/2))

dragged across to L1 and then double click the fill handle.