求修改代码

lagos

复制固定列的字符粘贴到指定工作表的列，向右粘贴到下一空白列。详情请看附件： 求修改代码.rar (11.6 KB, 下载次数: 3)

2024-1-1 18:11 上传

点击文件名下载附件

ttiemike

Sub CopyDataToSheet10()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim targetColumn As Long
    Dim i As Long
   
    ' 设置源工作表和目标工作表
    Set sourceSheet = ActiveSheet
    Set targetSheet = ThisWorkbook.Sheets("Sheet10")
   
    ' 检查源工作表D2是否为空
    If sourceSheet.Range("D2").Value = "" Then Exit Sub
   
    ' 获取源工作表的最后一行
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
   
    ' 获取目标工作表的下一空列
    targetColumn = targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column + 1
   
    ' 复制数据
    For i = 2 To 11
        targetSheet.Cells(i - 1, targetColumn).Value = sourceSheet.Range("D" & i).Value
    Next i
   
    ' 提示复制完成
    MsgBox "数据已成功复制到Sheet10的" & targetSheet.Cells(1, targetColumn).Address(False, False) & "列。"
End Sub

ttiemike

仅供参考。。。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.1
   
2.     Dim brr(1 To 10000, 1 To 100)
   
3.     Set sh = Sheets("Sheet10")
   
4.     sh.UsedRange = ""
   
5.     On Error Resume Next
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             If sht.[d2] <> Empty Then
   
9.                 n = n + 1: m = 0
   
10.                 With sht
    
11.                     r = .Cells(Rows.Count, 4).End(3).Row
    
12.                     If r > 0 Then
    
13.                         arr = .Range("d2:d" & r)
    
14.                         For i = 1 To UBound(arr)
    
15.                             m = m + 1
    
16.                             brr(m, n) = arr(i, 1)
    
17.                         Next
    
18.                     End If
    
19.                 End With
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     sh.[d2].Resize(m, n) = brr
    
24. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

gwjkkkkk

参与一下。。。