多列整合到一列

zy19880405

Sub zz()
Dim J As Long
Dim i As Integer
J = Sheet2.Range("A65535").End(xlUp).Row + 1

For i = 1 To 10
Sheet1.Cells(1, i).Resize(3550, 1).Copy
Sheet2.Cells(J, 1).PasteSpecial

Application.CutCopyMode = False
Next
End Sub


我自己试着写了一些 为什么一直都在重复在一个地方粘贴？
我按F8测试的时候 都是在这一句 Sheet2.Cells(J, 1).PasteSpecial 他并没有选择这一列最下面那个单元格 还是原来的那个范围再粘贴。。

蓝桥玄霜

把J = Sheet2.Range("A65535").End(xlUp).Row + 1这一句放在循环中即可。

everbest2015

Sub zhenghe()
    Dim ar, sh As Worksheet, sht As Worksheet, i&, k&, s As Variant
    Dim br(), m&
    On Error Resume Next
    Set sh = Sheets("已对上")
    If Err <> 0 Then
        Err.Clear
        Exit Sub
    End If
    ar = sh.UsedRange
  For i = 1 To UBound(ar)
        For k = 1 To UBound(ar, 2)
                s = ar(i, k)
                If s <> "" Then
                    m = m + 1
                    ReDim Preserve br(1 To 1, 1 To m)
                    br(1, m) = s
                End If
        Next
  Next
Set sht = Sheets("Sheet1")
With sht
        .[a:a].Clear
        .Cells(1, 1).Resize(m) = Application.Transpose(br)
End With
MsgBox "整合数据成功,共计" & m & "条记录!", , "提示"
End Sub