数据复制到另一个工作簿，每一行带日期时间，保存

lsyong

请求帮忙，

  把工作簿：MO ，里的工作表：input   的 E,F 两列，有内容的行 复制到
工作簿 HW-A  ，里面的工作表：HW-A ,  E,F,两列对应 放到B,C两列
A列 有放置日期时间， D列，是通过A列日期 转换成生产批号， 格式是 ：191026
代码放置在 HW-A 按钮

rardge2015

1. <blockquote>Option Explicit

复制代码

rardge2015

刚才忘了保存工作簿了，这个论坛功能有问题，重新编辑后代码不对了，只能重新发帖。

1. Option Explicit
   
2. 
   
3. Sub ToHW_A()
   
4.     Dim WKB As Workbook
   
5.     Dim arrData() As Variant
   
6.     Dim iRow As Long, iRecs As Long
   
7.    
   
8.     Application.ScreenUpdating = False
   
9.    
   
10.     ' 从当前工作簿读取数据
    
11.     With Sheets("Sheet1")
    
12.         ' 无数据则退出
    
13.         iRow = .Range("E" & Rows.Count).End(xlUp).Row
    
14.         iRecs = iRow - 1
    
15.         If iRecs < 1 Then Exit Sub Else arrData = .Range("E2:F" & iRow).Value
    
16.     End With
    
17.    
    
18.     ' 写入目标工作簿、表
    
19.     Set WKB = Workbooks.Open(ThisWorkbook.Path & "\HW-A.xlsx")
    
20.     With WKB.Sheets("HW-A")
    
21.         iRow = .Range("B" & Rows.Count).End(xlUp).Row
    
22.         .Range("A" & iRow + 1).Resize(iRecs).Value = Date + Time
    
23.         .Range("B" & iRow + 1).Resize(iRecs, 2).Value = arrData
    
24.         .Range("D" & iRow + 1).Resize(iRecs).Value = Format(Date, "yymmdd")
    
25.     End With
    
26.     WKB.Close SaveChanges:=True
    
27.    
    
28.     Set WKB = Nothing
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

lsyong

rardge2015 发表于 2019-10-26 09:38

非常感谢，可以了

lsyong

lsyong 发表于 2019-10-26 09:51
非常感谢，可以了

如果是D,E,F 3列，的话，代码怎么样改啊。

rardge2015

1. Option Explicit
   
2. 
   
3. Sub ToHW_A()
   
4.     Dim WKB As Workbook, Rng As Range
   
5.     Dim arrData() As Variant
   
6.     Dim iRow As Long, iRecs As Long
   
7.    
   
8.     ' 起始列列号、连续几列
   
9.     Const Col_Begin = "D"
   
10.     Const iCols = 3
    
11.    
    
12.     Application.ScreenUpdating = False
    
13.    
    
14.     ' 从当前工作簿读取数据
    
15.     With Sheets("Sheet1")
    
16.         ' 无数据则退出
    
17.         iRow = .Range(Col_Begin & Rows.Count).End(xlUp).Row
    
18.         iRecs = iRow - 1
    
19.         If iRecs < 1 Then Exit Sub Else arrData = .Range(Col_Begin & 2).Resize(iRecs, iCols).Value
    
20.     End With
    
21.    
    
22.     ' 写入目标工作簿、表
    
23.     Set WKB = Workbooks.Open(ThisWorkbook.Path & "\HW-A.xlsx")
    
24.     With WKB.Sheets("HW-A")
    
25.         iRow = .Range("B" & Rows.Count).End(xlUp).Row
    
26.         Set Rng = .Range("A" & iRow + 1)
    
27.         Rng.Resize(iRecs).Value = Date + Time
    
28.         Rng.Offset(, 1).Resize(iRecs, iCols).Value = arrData
    
29.         Rng.Offset(, 1 + iCols).Resize(iRecs).Value = Format(Date, "yymmdd")
    
30.     End With
    
31.     WKB.Close SaveChanges:=True
    
32.    
    
33.     Set Rng = Nothing
    
34.     Set WKB = Nothing
    
35.     Application.ScreenUpdating = True
    
36. End Sub

复制代码

lsyong

rardge2015 发表于 2019-10-26 22:43

非常感谢。你的帮助。