求助复制粘贴代码

hnzz416cxm

求助复制粘贴代码

ykcbf1100

做成模块，随时可以调用，方便一点。

2900357148

计算最后一行我是按照B列最后一行算的，有需要楼主可自行修改，测试没问题，楼主试一下。

Sub 自动粘贴()
    Dim Brow%
    Dim StrRange$
    With Worksheets(1)
        Brow = .Range("B20000").End(xlUp).Row
        For i = 3 To Brow
            If .Range("A" & i & ":P" & i).SpecialCells(xlCellTypeBlanks).Count < 16 Then
                StrRange = StrRange & "A" & i & ":P" & i & ","
            End If
        Next i
        .Range(Left(StrRange, Len(StrRange) - 1)).Copy Destination:=Worksheets(2).Range("A1")
    End With
End Sub

hnzz416cxm

此复制粘贴是定向固定的，其意：Sheet1复制到剪切板后，Sheet2可以任意点击A列单元格起始位置粘贴，麻烦大神再帮忙深入下

hnzz416cxm

2900357148 发表于 2022-12-16 13:37
计算最后一行我是按照B列最后一行算的，有需要楼主可自行修改，测试没问题，楼主试一下。

Sub 自动粘贴( ...

还是不能做到灵活粘贴

hnzz416cxm

2900357148 发表于 2022-12-16 13:37
计算最后一行我是按照B列最后一行算的，有需要楼主可自行修改，测试没问题，楼主试一下。

Sub 自动粘贴( ...

Sheet1往下加数据复制就不对了

2900357148

hnzz416cxm 发表于 2022-12-16 22:38
Sheet1往下加数据复制就不对了

明天帮你看一下，最好给我一张加了数据的图

hnzz416cxm

2900357148 发表于 2022-12-16 22:58
明天帮你看一下，最好给我一张加了数据的图

数据根a列、b列.....一样的格式

2900357148

稍微修改了一下，没有发现问题，你测试看看

Sub 自动粘贴()
    Dim Brow%
    Dim StrRange$
    Dim Rng As Range

    With Worksheets(1)
        Brow = .Range("B20000").End(xlUp).Row + 10
        For i = 3 To Brow
            For Each Rng In .Range("A" & i & ":P" & i)
                If Rng.Value <> Empty Then
                    StrRange = StrRange & "A" & i & ":P" & i & ","
                    Exit For
                End If
            Next
        Next i
        .Range(Left(StrRange, Len(StrRange) - 1)).Copy Destination:=Worksheets(2).Range("A1")
    End With
End Sub

练姐

Sub fz()

Dim i, l As Integer
i = InputBox("请填写放置数据的第一行，如第2行开始，即填数字2")
l = InputBox("请填写放置数据的第一列，如在C列开始，即填数字3")



Sheet1.Range("a3").CurrentRegion.Copy Sheets("sheet2").Cells(i, l)


End Sub