将一个单元格的值复制到另一个 sheet 但保留目标格式的宏

Question

我有一个 Sheet 名为“每日数据”和一个 Sheet 名为“JPY Dly”。我创建了一个按钮并编写了一个宏来从另一个文件导入数据并将其放入“每日数据”中的单元格 A1:D1。

然后我需要将这些值复制并粘贴到 Sheet“JPY Dly”的特定列中的下一个可用单元格中。

我在代码的粘贴部分使用了 Offset，但是当粘贴发生时，数据不会保持目标单元格的格式。我想要的只是复制“每日数据”中单元格的值，并让它们采用“JPY Dly”中预先确定的单元格格式。

这是我正在使用的代码。

Sub Import_DailyData()

Workbooks.Open "C:\Users\dbrown1\Downloads\exchange.csv"
'Opens the dowloaded file from the web

Workbooks("exchange.csv").Worksheets("exchange").Range("A8:AN9").Copy _
    Workbooks("FOREX TEST.xlsm").Worksheets("Daily Data").Range("A1")
'Copies the daily data into FOREX Workbook

Workbooks("exchange.csv").Close SaveChanges:=False
'Closes the downloaded sheet without saving

Kill ("C:\Users\dbrown1\Downloads\exchange.csv")

'Insert the "Write to sheets" portion of the Sub in here

Worksheets("Daily Data").Range("A2").Copy Sheets("JPY Dly").Range("C2000").End(xlUp).Offset(1, 0)
Worksheets("Daily Data").Range("F2").Copy Sheets("JPY Dly").Range("E2000").End(xlUp).Offset(1, 0)
Worksheets("Daily Data").Range("G2").Copy Sheets("JPY Dly").Range("F2000").End(xlUp).Offset(1, 0)
Worksheets("Daily Data").Range("E2").Copy Sheets("JPY Dly").Range("G2000").End(xlUp).Offset(1, 0)

'Below this you will see the ClearContents portion of the code
Worksheets("Daily Data").Range("A1:AN2").ClearContents


End Sub

你能告诉我如何只粘贴“每日数据”中的值，并且它们采用“JPY Dly”中的单元格格式吗？

更新这是 chrisnielsen 推荐的更新代码和下载的“exchange”文件的屏幕截图。

Sub Import_DailyData()

    Dim wbCSV As Workbook
    Dim wsCSV As Worksheet
    Dim wsDestination As Worksheet
    Dim DestRow As Long

Set wbCSV = Workbooks.Open("C:\Users\dbrown1\Downloads\exchange.csv")
Set wsCSV = wbCSV.Worksheets("exchange")
'Opens the dowloaded file from the web

Set wsDestination = ThisWorkbook.Worksheets("JPY Dly")
'Copies the daily data into FOREX Workbook


'Closes the downloaded sheet without saving

'Insert the "Write to sheets" portion of the Sub in here

With wsDestination
        DestRow = .Cells(.Rows.Count, 3).End(xlUp) + 1
    
        ' Copy data
        .Cells(DestRow, 3).Value = wsCSV.Cells(2, 1).Value
        .Cells(DestRow, 5).Value = wsCSV.Cells(2, 3).Value
        .Cells(DestRow, 6).Value = wsCSV.Cells(2, 4).Value
        .Cells(DestRow, 7).Value = wsCSV.Cells(2, 2).Value
End With
'Below this you will see the ClearContents portion of the code
'Worksheets("Daily Data").Range("A1:AN2").ClearContents
Workbooks("exchange.csv").Close SaveChanges:=False
'Kill ("C:\Users\dbrown1\Downloads\exchange.csv")

End Sub

Answer 1

在 ACCitonMan 的评论基础上使用特殊粘贴。以下代码从单元格 A1 中获取文本并将其粘贴到单元格 A2 中，同时保留单元格 A2 中的任何格式。

Sub pasteSpec()
    Dim ws As Excel.Worksheet
    Dim cRng As Excel.Range
    Dim pRng As Excel.Range
    
    Set ws = ThisWorkbook.Worksheets(1)
    
    Set cRng = ws.Range("A1")
    Set pRng = ws.Range("A2")
    
    cRng.Copy
    pRng.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False 'stops marching ants when using .copy
    
End Sub

可以在文档中找到其他粘贴类型 here。

Answer 2

虽然 Copy/Paste 值会起作用，但使用源单元格和目标单元格的值属性更简洁。这将保留目标单元格格式。

此外，还有许多其他改进的机会

使用工作簿和工作表引用
不需要中间每日数据Sheet。
无需重复 .End(xlUp) 位
不需要 Kill 行上的 ( )（事实上这有副作用，虽然这不是问题，但最终会咬你）

Sub Import_DailyData()
    Dim wbCSV As Workbook
    Dim wsCSV As Worksheet
    Dim wsDestination As Worksheet
    Dim DestRow As Long
    
    'Open the dowloaded file from the web, and get references
    Set wbCSV = Workbooks.Open("C:\Users\dbrown1\Downloads\exchange.csv")
    Set wsCSV = wbCSV.Worksheets("exchange")
    
    ' Reference the destination
    Set wsDestination = ThisWorkbook.Worksheets("JPY Dly") ' Assuming FOREX TEST.xlsm contains this code
    ' If FOREX TEST.xlsm does not contains this code, use this instead of the previous line
    'Set wsDestination = Application.Workbooks("FOREX TEST.xlsm").Worksheets("JPY Dly")
    
    ' get destination row
    With wsDestination
        DestRow = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
    
        ' Copy data
        .Cells(DestRow, 3).Value = wsCSV.Cells(2, 1).Value
        .Cells(DestRow, 5).Value = wsCSV.Cells(2, 6).Value
        .Cells(DestRow, 6).Value = wsCSV.Cells(2, 7).Value
        .Cells(DestRow, 7).Value = wsCSV.Cells(2, 5).Value
    End With
    
    'Close and delete the downloaded workbook without saving
    wbCSV.Close SaveChanges:=False
    Kill "C:\Users\dbrown1\Downloads\exchange.csv"
    
End Sub

将一个单元格的值复制到另一个 sheet 但保留目标格式的宏

Macro to copies value of a cell to another sheet but retain destination Format

excel

vba

copy-paste