Скопируйте данные и вставьте как значения - PullRequest
0 голосов
/ 08 марта 2019

Мой код в настоящее время копирует строки данных из исходных рабочих книг в Mastercopy excel.Тем не менее, я хотел бы вставить значения в виде числа.Любая идея о том, как я могу изменить в коде ниже?

Sub copyDataFromMultipleWorkbooksIntoMaster()

Dim FolderPath As String, Filepath As String, Filename As String

FolderPath = "D:\Users\AlexPeteson\Desktop\Test File\Downloads\"

Filepath = FolderPath & "*.csv"

Filename = Dir(Filepath)

Dim lastrow As Long, lastcolumn As Long

Dim erow

Do While Filename <> ""
Workbooks.Open (FolderPath & Filename)

'Find the last non-blank cell in column A(1)
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

'Find the last non-blank cell in row 1
lastcolumn = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column

Range(Cells(3, 1), Cells(lastrow, lastcolumn)).copy
Application.DisplayAlerts = False
ActiveWorkbook.Close

erow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 2), Cells(erow, 10))

Filename = Dir

Loop

End Sub

1 Ответ

0 голосов
/ 08 марта 2019

Итак, отредактируйте имя основного листа на Set ws = ...

Option Explicit
Sub copyDataFromMultipleWorkbooksIntoMaster()

    Dim FolderPath As String, Filepath As String, Filename As String
    Dim wb As Workbook, ws As Worksheet, wbTemp As Workbook, wsTemp As Worksheet

    'Define your master workbook and sheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("YourMasterSheetName")

    FolderPath = "D:\Users\AlexPeteson\Desktop\Test File\Downloads\"

    Filepath = FolderPath & "*.csv"

    Filename = Dir(Filepath)

    Dim lastrow As Long, lastcolumn As Long

    Dim erow As Long

    Do While Filename <> ""
        Set wbTemp = Workbooks.Open(FolderPath & Filename, UpdateLinks:=False, ReadOnly:=True)
        Set wsTemp = wbTemp.Sheets(1) ' lets suppose it is always on the first sheet in the workbook

        With wsTemp
            'Find the last non-blank cell in column A(1)
            lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
            'Find the last non-blank cell in row 1
            lastcolumn = .Cells(3, Columns.Count).End(xlToLeft).Column
            .Range(Cells(3, 1), Cells(lastrow, lastcolumn)).Copy
        End With
        'Find the last blank cell on your master sheet
        erow = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1
        ws.Cells(erow, 2).PasteSpecial xlPasteValues
        wbTemp.Close Savechanges:=False
        Set wbTemp = Nothing
        Set wsTemp = Nothing
        Filename = Dir
    Loop

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...