Цель этого макроса - скопировать данные из многих входных листов в лист« Основание »основной/основной книги под названием« Компенсация test5 "на основе двух критериев. Макрос должен: 1) проверить, есть ли входной лист в тот же месяц, что и основная книга. Если это так, 2) он должен скопировать соответствующие данные для соответствующих маршрутов. В настоящее время я получаюПолучение «ошибки времени выполнения» 13: Тип несоответствия «-error при сравнении двух ячеек
Run-time error '13': Type mismatch
в строке 58 (комментарий с заглавной буквы в коде). Что здесь не так?
Я загрузил и привел пример основной книги и примера одной из входных книг. У ячейки даты (ячейка B9) входных книг обычно есть месяц, за которым следуют «-» и год, fx «Февраль-2016». Я раскалываю его в строке 58, чтобы сделать его сопоставимым с месяцами в первом ряду листа «Основа» в основной книге.
Sub combineall()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Call lista
Call CopyLookup
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Workbooks("Kompensation test5").Sheets("List").Delete
Workbooks("Kompensation test5").Sheets("Basis").Activate
End Sub
Sub CopyLookup()
Dim Path As String
Dim Fil As String
Dim strName As String
Dim wbk_main As Workbook, wbk_input As Workbook
Dim ws_main As Worksheet, ws_input As Worksheet
Dim rng_main As Range, rng_main_date As Range, rng_input As Range, rng_input_date As Range
Dim c_main As Range, c_main_date As Range, c_input As Range
i = 2
While Workbooks("Kompensation test5").Sheets("List").Cells(i, 1) <> ""
t = Workbooks("Kompensation test5").Sheets("List").Cells(i, 1)
Set wbk_main = ActiveWorkbook
Path = "I:\folderpath" & t
q = 1
'Start outer loop
Do While q <> ""
Set wbk_input = Workbooks.Open(Path)
Set ws_input = wbk_input.Sheets(1)
Set rng_main_date = ThisWorkbook.Sheets("Basis").Range("1:1")
Set rng_input_date = ws_input.Range("B9")
Set rng_input = ws_input.Range("R10:AL10")
For Each c_main_date In rng_main_date
If c_main_date.Value <> "" Then
For Each c_input In rng_input_date
If c_input.Value <> "" Then
For x = 1 To 100
If InStr(Workbooks("Kompensation test5").Sheets("Basis").Cells(1, x), Split(Replace(Workbooks(ws_input).Range(rng_input_date).Value, "-", " "), " ")) > 0 Then 'ERROR HERE!
k = x
End If
Next x
Workbooks("Kompensation test5").Sheets("Basis").Range(Cells(4, k - 1), Cells(19, k - 1)).Select
End If
Next c_input
End If
Next c_main_date
Set rng_main = Workbooks("Kompensation test5").Sheets("Basis").Range(Cells(4, k - 1), Cells(19, k - 1))
'Split cell if containing many values
ws_input.Range("B10").Select
Selection.TextToColumns Destination:=Range("R10"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
TrailingMinusNumbers:=True
'Loop through each cell in col I in sheet 2:
For Each c_main In rng_main
If c_main.Value <> "" Then
For Each c_input In rng_input
If c_input.Value = c_main.Value Then
c_main.Offset(0, 3).Value = wbk_input.Sheets(1).Range("F13").Value
q = ""
'Move on to next cell in sheet 2:
Exit For '(exits the "For Each c_input In rng_input" loop)
End If
Next c_input
End If
Next c_main
rng_input.Delete
wbk_input.Close False
Loop
i = i + 1
Wend
End Sub
Sub lista()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = Worksheets.Add
With ActiveSheet
.Name = "List"
End With
fldrpath = "I:\folderpath"
Set objFolder = objFSO.GetFolder(fldrpath)
ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & "are:"
For Each objFile In objFolder.Files
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Делает смысл :) Пробовал оба подхода. Оба производили ту же ошибку, что и раньше (в той же строке). – Saud
Затем разделите каждый шаг строки ошибки на одну строку и попытайтесь выяснить, где произошла ошибка. – gizlmo