Блог

Просто быстрый вопрос относительно вставки. У меня есть скрипт, который экспортирует отдельные строки во вновь созданную книгу. Однако проблема в том, что вставленные значения представлены в виде изображения. Кроме того, комментарии пропускаются. Я использовал тот же код для вставки в другие листы той же книги, и проблем нет.

Кажется, я не могу найти причину. Любая помощь будет принята с благодарностью.

Спасибо

 Private Sub DC_1Month_Button_Click()
'Searches for crews working on MFDC (7343) and exports a new spreadsheet looking 3 weeks ahead for each person

If MsgBox("Export DC individual schedules?") = vbNo Then
    Exit Sub
End If

On Error GoTo CleanFail

Dim nowCol As Integer, lastCol As Integer, endCol As Integer, crewRow As Integer
Dim masterSheet As Worksheet, newExcel As Object, newBook As Workbook, newSheet As Worksheet
Dim startRow As Integer, endRow As Integer
Dim currentName As String, currentProject As String

startRow = 3
endRow = UsedRange.Row - 1   UsedRange.Rows.count
lastcoln = UsedRange.Column - 1   UsedRange.Columns.count
Set masterSheet = ThisWorkbook.Worksheets("Master Schedule")

'Find columns for today and date 3 weeks after
nowCol = Range(Cells(2, 1), Cells(2, lastcoln)).Find(what:=Month(Date) amp; "/" amp; Day(Date) amp; "/" amp; Year(Date)).Column
endCol = Range(Cells(2, 1), Cells(2, lastcoln)).Find(what:=Month(DateAdd("d", 30, Date)) amp; "/" amp; Day(DateAdd("d", 30, Date)) amp; "/" amp; Year(DateAdd("d", 30, Date))).Column

'Disable screen flashing while doing copying and exports
Application.ScreenUpdating = False

'Loop through crew members
For i = 3 To endRow
    'Store current row's values
    currentName = Replace(ActiveSheet.Cells(i, 2).Value, "SA: ", "")
    currentProject = ActiveSheet.Cells(i, 3).Value

    'Search the value from the Project column for the MFDC project number
    If InStr(1, currentProject, "7343") > 0 Then

    'Load schedule template
    Set newExcel = CreateObject("Excel.Application")
    newExcel.DisplayAlerts = False
    newExcel.Workbooks.Open "\VALGEOFS01SurveyProjectManagers304ScheduleTemplatesDC_3Week_Template.xlsx"
    Set newBook = newExcel.Workbooks(1)
    Set newSheet = newBook.Worksheets(1)

    'Copy and paste header rows
    masterSheet.Range(masterSheet.Cells(1, nowCol), masterSheet.Cells(2, endCol)).Copy 'Destination:=newSheet.Range("A1")
    Application.Wait (Now   TimeValue("0:00:01"))
    newSheet.Range(newSheet.Cells(1, 6), newSheet.Cells(1, endCol - 1)).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False

    'Copy and paste crew member's location
    masterSheet.Range(masterSheet.Cells(i, 2), masterSheet.Cells(i, 6)).Copy 'Destination:=newSheet.Range("A3")
    Application.Wait (Now   TimeValue("0:00:01"))
    newSheet.Range("A3").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False

    'Copy schedule data for crew member
    masterSheet.Range(masterSheet.Cells(i, nowCol), masterSheet.Cells(i, endCol)).Copy
    Application.Wait (Now   TimeValue("0:00:01"))
    newSheet.Cells(3, 6).PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

    'Save individual's schedule
    With newBook
        .Title = currentName amp; " MFDC Schedule"
        .SaveAs Filename:="\VALGEOFS01SurveyProjectManagers304ScheduleMFDC Individual Schedules" amp; currentName amp; " MFDC Schedule " amp; Format(Date, "yymmdd") amp; ".xlsx", AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
        .Close (True)
    End With

    End If
Next i

CleanExit:
    MsgBox "Export complete"
    'Restore normal screen updating
    Application.ScreenUpdating = True
    Exit Sub

CleanFail:

    If Err.Number <> 0 Then
        Msg = "Error # " amp; Str(Err.Number) amp; " was generated by " amp; Err.Source amp; Chr(13) amp; Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
    Resume CleanExit
    Resume

End Sub