Ошибка выполнения 1004 при выполнении одного и того же кода для разных рабочих книг Excel - PullRequest
0 голосов
/ 25 октября 2019

При выполнении приведенного ниже кода он работает для одной рабочей книги Excel, но при попытке сделать то же самое с другой рабочей книгой выдает ошибку времени выполнения при поиске первого пустого столбца

Я попытался изменитькод, применяя различные значения, но он работает только для одной рабочей книги Excel. Но, насколько я знаю, я не написал ничего статического, связанного с одной рабочей книгой, в моем коде

unusedcolumn = Rows(1).SpecialCells(xlCellTypeBlanks)(1).Column

'Open a excel file
'Find last cell number of row A from data sheet
'Find the first blank column
'Add rule run date to first blank column
'Find age and convert to years
'sort by small to high by age column

Sub age()
Dim OpenWb As Workbook
With Application.FileDialog(msoFileDialogFilePicker)
    'Makes sure the user can select only one file
    .AllowMultiSelect = False
    'Filter to just the following types of files to narrow down selection options
    .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
    'Show the dialog box
    .Show

    'Store in fullpath variable
    fullpath = .SelectedItems.Item(1)

    'Actions in raw data sheet
    Set OpenWb = Workbooks.Open(fullpath)
    Dim wsData As Worksheet
    Set wsData = OpenWb.Worksheets("Sheet1")

    ' Find last cell number of row A from data sheet
    Dim last As Double
    Dim Cell As Range
    With OpenWb.Worksheets("Sheet1")
        last = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    OpenWb.Worksheets("Sheet1").Range("A1").Select
    OpenWb.Worksheets("Sheet1").ListObjects.Add(xlSrcRange, Selection.CurrentRegion, , xlYes).Name = _
    "MyTable"

    'Find the first blank column
    Dim unusedcolumn As Range
    unusedcolumn = Rows(1).SpecialCells(xlCellTypeBlanks)(1).Column
    Dim irow As String
    irow = Worksheets("Sheet1").Cells(Rows(unusedcolumn).Count, 1).End(xlUp).Row

    'Add rule run date to first blank column
    Cells(irow, unusedcolumn) = "Rule run date"
    OpenWb.Worksheets("Sheet1").Select
    Dim i As Double
    For i = 1 To last - 1
        Cells(irow + i, unusedcolumn).value = "11/15/2019"
    Next i

    'Find age
    OpenWb.Worksheets("Sheet1").Rows("1:1").Select
    Dim unusedcolumn2 As Integer
    unusedcolumn2 = Rows(1).SpecialCells(xlCellTypeBlanks)(1).Column
    Dim irow2 As String
    irow2 = Worksheets("Sheet1").Cells(Rows(unusedcolumn).Count, 1).End(xlUp).Row
    Cells(irow2, unusedcolumn2) = "Age"
    OpenWb.Worksheets("Sheet1").Select
    Dim J As Double
    Cells(irow2 + 1, unusedcolumn2).Formula = "=MyTable[[#All],[Rule run date]]-MyTable[[#All],[BIRTH_YEAR]]"

    'Covert age to years
    Dim unusedcolumn3 As Integer
    unusedcolumn3 = Rows(1).SpecialCells(xlCellTypeBlanks)(1).Column
    Dim irow3 As String
    irow3 = Worksheets("Sheet1").Cells(Rows(unusedcolumn).Count, 1).End(xlUp).Row
    Cells(irow3, unusedcolumn3) = "Age in years"
    OpenWb.Worksheets("Sheet1").Select
    Dim k As Double
    Cells(irow3 + 1, unusedcolumn3).Formula = "=DATEDIF(0, MyTable[[#All],[Age]], ""y"") & ""years"" & DATEDIF(0, MyTable[[#All],[Age]], ""ym"") & ""months"" & DATEDIF(0, MyTable[[#All],[Age]], ""md"") & "" days"""
    Worksheets("Sheet1").UsedRange.value = Worksheets("Sheet1").UsedRange.value
    OpenWb.Worksheets("Sheet1").Rows("1:1").Select
    Dim f1 As String
    f1 = Selection.Find(What:="Age", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Column
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:=Cells( _
   f1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...