VBA Excel: объект с кодом ошибки 438 не поддерживает это свойство в моем коде VBA - PullRequest
Новая
       12

VBA Excel: объект с кодом ошибки 438 не поддерживает это свойство в моем коде VBA

1 голос
/ 09 октября 2019

Я новичок в VBA. Я написал код для разделенного файла, когда count = 10000, и переместил отдельные данные в ячейку, когда данные не являются целыми числами. Затем мне говорят, что объект не поддерживает это свойство или метод. Мне нужна помощь, если кто-то знает ответ, почему это происходит. Спасибо. 

Sub DIP_Split()
  Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeToCopy As Range
  Dim RangeOfHeader As Range        'data (range) of header row
  Dim Filename As String
  Dim WorkbookCounter As Integer
  Dim RowsInFile                    'how many rows (incl. header) in new files?

  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 10000                   'as your example, just 10 rows per file

  'Copy the data of the first row (header)
  Set RangeOfHeader = ThisSheet.Range(("A1:A3"), ThisSheet.Cells(1, NumOfColumns))

  For p = 4 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 2
    Set wb = Workbooks.Add

    'Paste the header row in new file
    RangeOfHeader.Copy wb.Sheets(1).Range("A1:A3")

    'Delete Header
    wb.Sheets(1).Rows(1).EntireRow.Delete


    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 3, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A3")

    'Create Title and Merge Cell
    wb.Sheets(1).Columns("K:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    wb.Sheets(1).Range("K1").Font.Name = "Angsana New"
    wb.Sheets(1).Range("K1").Value = "xxxx"
    wb.Sheets(1).Range("K1:K2").Merge

    wb.Sheets(1).Range("O1").HorizontalAlignment = xlCenter
    wb.Sheets(1).Range("O1").VerticalAlignment = xlVAlignCenter
    wb.Sheets(1).Range("O1").Font.Bold = True
    wb.Sheets(1).Range("O1").Font.Name = "Angsana New"
    wb.Sheets(1).Range("O1").Value = "xxx"
    wb.Sheets(1).Range("O1:O2").Merge

 'If not integer move to next row
 For Each r In wb.Sheet(1).Range("J3:J100")
    If IsNumeric(r.Value) = False Then
     r.Cut
     r.Offset(, 1).Select
     ActiveSheet.Paste
    End If
 Next r

    'Save the new workbook, and close it
    wb.SaveAs ThisWorkbook.Path & Filename & Format(Now, "DD-MM-YYYY") & -WorkbookCounter
    wb.Close

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub
...