The code works fine when I dont use the first command to clear contents.After clearing the contents I got a "Paste Special Error" when I used the command to consolidate certain rows and columns.I need to reduce the size of certain rows and columns(wrap text) as it is taking a lot of space
Private Sub Btn_clear_Click()
ThisWorkbook.Worksheets("Main").Cells.ClearContents
End Sub
(I am to able to clear the cell contents using this)
Sub Credit_Risk_Components()
Const FOLDER As String = "C:\SBI_Files\"
Const cStrWSName As String = "Credit Risk Components"
'(I got a paste value error here)
On Error GoTo ErrorHandler
Dim i As Integer
Dim fileName As String
' Cleaning Credit Indicators (Both amount and percentage) '
ThisWorkbook.Worksheets(cStrWSName).Range("C8:C16").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C20").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C23:C25").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C40:C47").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C52:C59").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C66").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C68").ClearContents
ThisWorkbook.Worksheets(cStrWSName).Range("C71:C73").ClearContents
'Cleaning the Annexure Section'
ThisWorkbook.Worksheets(cStrWSName).Range("H6:K200").UnMerge
ThisWorkbook.Worksheets(cStrWSName).Range("H6:K200").ClearFormats
ThisWorkbook.Worksheets(cStrWSName).Range("H6:K200").ClearContents
(I want to resize certain rows and columns,as the rows and columns are taking a lot of space which isn't required)
'Building the Annexure Section'
ThisWorkbook.Worksheets(cStrWSName).Range("H4").Value = "Annexure I"
ThisWorkbook.Worksheets(cStrWSName).Range("H4:K4").Merge
ThisWorkbook.Worksheets(cStrWSName).Range("H4:K4").HorizontalAlignment = xlCenter
ThisWorkbook.Worksheets(cStrWSName).Range("H4:K4").Font.Bold = True
ThisWorkbook.Worksheets(cStrWSName).Cells(5, 2).Copy Cells(5, 9)
ThisWorkbook.Worksheets(cStrWSName).Cells(5, 3).Copy Cells(5, 10)
ThisWorkbook.Worksheets(cStrWSName).Cells(5, 4).Copy Cells(5, 11)
fileName = Dir(FOLDER, vbDirectory)
Do While Len(fileName) > 0
If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then
i = i + 1
Dim currentWkbk As Excel.Workbook
Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName)
ThisWorkbook.Worksheets(cStrWSName).Range("C10").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C10").Value + currentWkbk.Sheets(cStrWSName).Range("C10").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C11").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C11").Value + currentWkbk.Sheets(cStrWSName).Range("C11").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C13").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C13").Value + currentWkbk.Sheets(cStrWSName).Range("C13").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C14").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C14").Value + currentWkbk.Sheets(cStrWSName).Range("C14").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C16").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C16").Value + currentWkbk.Sheets(cStrWSName).Range("C16").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C20").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C20").Value + currentWkbk.Sheets(cStrWSName).Range("C20").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C23").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C23").Value + currentWkbk.Sheets(cStrWSName).Range("C23").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C24").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C24").Value + currentWkbk.Sheets(cStrWSName).Range("C24").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C25").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C25").Value + currentWkbk.Sheets(cStrWSName).Range("C25").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C40").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C40").Value + currentWkbk.Sheets(cStrWSName).Range("C40").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C41").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C41").Value + currentWkbk.Sheets(cStrWSName).Range("C41").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C42").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C42").Value + currentWkbk.Sheets(cStrWSName).Range("C42").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C43").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C43").Value + currentWkbk.Sheets(cStrWSName).Range("C43").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C44").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C44").Value + currentWkbk.Sheets(cStrWSName).Range("C44").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C45").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C45").Value + currentWkbk.Sheets(cStrWSName).Range("C45").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C46").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C46").Value + currentWkbk.Sheets(cStrWSName).Range("C46").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C47").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C47").Value + currentWkbk.Sheets(cStrWSName).Range("C47").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C52").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C52").Value + currentWkbk.Sheets(cStrWSName).Range("C52").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C53").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C53").Value + currentWkbk.Sheets(cStrWSName).Range("C53").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C54").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C54").Value + currentWkbk.Sheets(cStrWSName).Range("C54").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C56").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C56").Value + currentWkbk.Sheets(cStrWSName).Range("C56").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C57").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C57").Value + currentWkbk.Sheets(cStrWSName).Range("C57").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C58").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C58").Value + currentWkbk.Sheets(cStrWSName).Range("C58").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C59").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C59").Value + currentWkbk.Sheets(cStrWSName).Range("C59").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C66").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C66").Value + currentWkbk.Sheets(cStrWSName).Range("C66").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C68").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C68").Value + currentWkbk.Sheets(cStrWSName).Range("C68").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C71").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C71").Value + currentWkbk.Sheets(cStrWSName).Range("C71").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C72").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C72").Value + currentWkbk.Sheets(cStrWSName).Range("C72").Value
ThisWorkbook.Worksheets(cStrWSName).Range("C73").Value = ThisWorkbook.Worksheets(cStrWSName).Range("C73").Value + currentWkbk.Sheets(cStrWSName).Range("C73").Value
'Adding the Prudential/ Industrial Exposures to the annexure'
rowNum = Range("I65536").End(xlUp).Row
ThisWorkbook.Worksheets(cStrWSName).Cells(rowNum + 1, 8).Value = Left(currentWkbk.Name, Len(currentWkbk.Name) - 4)
ThisWorkbook.Worksheets(cStrWSName).Cells(rowNum + 1, 8).Font.Bold = True
currentWkbk.Sheets(cStrWSName).Range("B29:D38").Copy
ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowNum + 2, 9), Cells(rowNum + 11, 11)).PasteSpecial xlPasteValues
ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowNum + 2, 9), Cells(rowNum + 11, 11)).PasteSpecial xlPasteFormats
currentWkbk.Sheets(cStrWSName).Range("B76:D79").Copy
ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowNum + 12, 9), Cells(rowNum + 15, 11)).PasteSpecial xlPasteValues
ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowNum + 12, 9), Cells(rowNum + 15, 11)).PasteSpecial xlPasteFormats
currentWkbk.Close
End If
fileName = Dir
Loop
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Comment out error handler and check what line fails.
FYI, .xlsx does not allow any code (unless your code is run outside).
Based on your error message there is something wrong with PasteSpecial method you use in the end. Try copying the same manually.
BTW, your code should be refactored.
Related
I am working on a workbook that has three tabs. My Customer list Addresses, Outsource customer listing addresses: and Output No Match:. I am looking to run my list agents an outsource list and if my address list does not match any addresses on the out source list. It outputs on the No match tab.
I have built a working document but it is so slow and feel someone here could really help point me in the right direction.
All three sheets column headers ("Customer Name","Address 1","Address 2","City","State","Zip Code")
I am using a code similar to the one below to find none matches on all the columns. It only looks at the first few characters in hope to speed things up but i am getting no where fast.
I am running it on a loop somewhat like this which seems to be very incessant and slow when comparing addresses agent 200,000 records.
For I = 2 To LastRow
If Left(UCase(Trim(wsAddressS_1.Cells(1 + I, 6).Value)), 5) =
Left(UCase(VLookLike(wsAddressS_1.Cells(1 + I, 6).Value, wsAddressS_2.Range("F1:F" & LastRow2 + 10))), 5) Then
Match_Zip = "Match"
Else
Match_Zip = "No Match"
End If
If strMatchZip <> "Match" Then
LastRow1 = wsAddressS_4.Range("F" & Rows.Count).End(xlUp).Row
wsAddressS_4.Cells(LastRow4 + 1, 1).Value = wsAddressS_1.Cells(1 + I, 1).Value
wsAddressS_4.Cells(LastRow4 + 1, 2).Value = wsAddressS_1.Cells(1 + I, 2).Value
wsAddressS_4.Cells(LastRow4 + 1, 3).Value = wsAddressS_1.Cells(1 + I, 3).Value
wsAddressS_4.Cells(LastRow4 + 1, 4).Value = wsAddressS_1.Cells(1 + I, 4).Value
wsAddressS_4.Cells(LastRow4 + 1, 5).Value = wsAddressS_1.Cells(1 + I, 5).Value
wsAddressS_4.Cells(LastRow4 + 1, 6).Value = wsAddressS_1.Cells(1 + I, 6).Value
End If
Sleep 10
DoEvents
Next I
e.g VLookLike
Private Function VLookLike(txt As String, rng As Range) As String
Dim temp As String, e, n As Long, a()
Static RegX As Object
If RegX Is Nothing Then
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Global = True
.IgnoreCase = True
.Pattern = "(\S+).*" & Chr(2) & ".*\1"
End With
End If
With RegX
For Each e In rng.Value
If UCase$(e) = UCase(txt) Then
VLookLike = e
Exit For
End If
temp = Join$(Array(e, txt), Chr(2))
If .test(temp) Then
n = n + 1
ReDim Preserve a(1 To 2, 1 To n)
a(2, n) = e
Do While .test(temp)
a(1, n) = a(1, n) + Len(.Execute(temp)(0).submatches(0))
temp = Replace(temp, .Execute(temp)(0).submatches(0), "")
Loop
End If
Next
End With
If (VLookLike = "") * (n > 0) Then
With Application
VLookLike = .HLookup(.Max(.Index(a, 1, 0)), a, 2, False)
End With
End If
End Function
Any help or suggestions would be much appreciated!
I haven't read all the code, sorry, but I have had problems on comparing strings. Perhaps it would work if you tell vba that you are gonna compare 2 strings. You could use the function Cstr() for example
CStr(Left(UCase(StrAddress), 3)) = CStr(Left(UCase(VLookLike(StrAddress, rng2)), 3))
can any one find any error? For some reason when i add last2 it gives na object defined error.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim src As Workbook
' Abrir EXCEL
Set src = Workbooks.Open
("U:\Mecânica\Produção\Manutenção_teste\TOA\manTOA.xlsm", True, False)
WS_Count = src.Worksheets.Count
For o = 1 To WS_Count
src.Worksheets(o).Unprotect password:="projmanutencao"
Next o
last = src.Worksheets("Manutencao").Range("A65536").End(xlUp).Row
folha = manutencaoexp.Label27.Caption
last2 = src.Worksheets("saidas").Range("A65536").End(x1Up).Row
' Escrever Registos
If manutencaoexp.ComboBox4 = "" Then
MsgBox "Introduzir todos os dados"
GoTo fim
Else
src.Worksheets("Manutencao").Cells(last + 1, 1) = Now() 'data
src.Worksheets("Manutencao").Cells(last + 1, 2) = manutencaoexp.Label28.Caption 'nº equipamento
src.Worksheets("Manutencao").Cells(last + 1, 3) = manutencaoexp.ComboBox5 'avaria
src.Worksheets("Manutencao").Cells(last + 1, 4) = manutencaoexp.ComboBox4 'serviços
src.Worksheets("Manutencao").Cells(last + 1, 5) = manutencaoexp.ComboBox7 'produtos
src.Worksheets("Manutencao").Cells(last + 1, 6) = Application.ThisWorkbook.Worksheets(folha).Cells(Monitorform.ComboBox1.ListIndex + 2, 32).Text 'duração
src.Worksheets("Manutencao").Cells(last + 1, 7) = manutencaoexp.TextBox2 'operario
src.Worksheets("Manutencao").Cells(last + 1, 8) = manutencaoexp.ComboBox6 'tipo de manutenção
src.Worksheets("Manutencao").Cells(last + 1, 9) = manutencaoexp.TextBox3 'quantidade
src.Worksheets("saidas").Cells(last2 + 1, 1) = manutencaoexp.ComboBox7 'código/produtos
'manutencaoexp.Hide
manutencaoexp.ComboBox7 = ""
manutencaoexp.TextBox3 = ""
MsgBox "Dados Introduzidos com sucesso"
End If
For o = 1 To WS_Count
src.Worksheets(o).Protect password:="projmanutencao"
Next o
Application.DisplayAlerts = False 'IT WORKS TO DISABLE ALERT PROMPT
'SAVES FILE USING THE VARIABLE BOOKNAME AS FILENAME
src.Save
Application.DisplayAlerts = True 'RESETS DISPLAY ALERTS
' CLOSE THE SOURCE FILE.
src.Close True ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
fim:
End Sub
My problem is that i want to run
src.Worksheets("saidas").Cells(last2 + 1, 1) = manutencaoexp.ComboBox7
but i get na error on
last2 = src.Worksheets("saidas").Range("A65536").End(x1Up).Row
Other than that everything is running fine.
If there's any other way around to solve this error , maybe adding another button or something else.
last2 = src.Worksheets("saidas").Range("A65536").End(x1Up).Row
If you look VERY carefully at this line, you'll notice that you actually have the number 1 instead of the letter L in End(x1Up)
How that happened, I have no idea. So change the line to:
last2 = src.Worksheets("saidas").Range("A65536").End(xlUp).Row
I want to use a if-function to distingiush between two sceneraios.
For Each Cell In Tabelle3.Range("A" & lastrow2)
Option A: If Cell <> "" Then run code
Option B: If Cell = "" Then skip this empty cell and go on with the next one
Here the whole code:
Sub IfFunction()
Dim lastrow2 As Long
lastrow2 = Tabelle3.Range("A" & Rows.Count).End(xlUp).Row
Set myrange2 = Tabelle8.UsedRange
For i = 2 To lastrow2
For Each Cell In Tabelle3.Range("A" & lastrow2)
If Cell = "" Then i = i + 1
Else: i = i
Tabelle3.Cells(7 + i, 19) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 3, False)
Tabelle3.Cells(7 + i, 20) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 4, False)
Tabelle3.Cells(7 + i, 21) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 5, False)
Next i
End If
End Sub
When I try to run this code, it does not execute because an error occurs that there is a 'ELSE without IF'-Function.
Does anyone know how I can use an IF-function here or what to use instead? Thanks. :)
if you continue writing after Then this means the If statement consists of one line only:
If Cell = "" Then i = i + 1 'End If automatically here
Then the Else has to be in that line too:
If Cell = "" Then i = i + 1 Else i = i 'End If automatically here
If you want to use a multi line If statement
If Cell = "" Then
i = i + 1
Else
i = i
End If
But …
because i = i doesn't do anything you can just write
If Cell = "" Then i = i + 1
and omit the Else part completely because it does nothing at all.
And anther but …
because you are using a For i the Next i increments i automatically and you don't need to increment it yourself. There is no i = i + 1 needed
your code has to For but one Next only, which would result in a syntax error
furthermore the Next i is intertwined with a If-Then-Else block code which would also result in a syntax error
finally I guess you're iterating twice along Tabelle3 column A cells from row 2 to last not empty one, while you only need it once
Summing all that up, I'd say you can use this code:
Option Explicit
Sub IfFunction()
Dim myrange2 As Range, cell As Range
Set myrange2 = Tabelle8.UsedRange
With Tabelle3
For Each cell In .Range("A2:A" & .Cells(.Rows.count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
cell.Offset(7, 18) = Application.WorksheetFunction.VLookup(cell.Offset(7), myrange2, 3, False)
cell.Offset(7, 19) = Application.WorksheetFunction.VLookup(cell.Offset(7), myrange2, 4, False)
cell.Offset(7, 20) = Application.WorksheetFunction.VLookup(cell.Offset(7), myrange2, 5, False)
Next
End With
End Sub
Okay that was actually way to simple :D I was running through the same column twice by
For Each Cell In Tabelle3.Range("A" & lastrow2)
If Cell = "" Then i = i + 1
Else: i = i
and
For i = 2 To lastrow2
Instead I can simply use:
For i = 2 To lastrow2
If Tabelle3.Cells(7 + i, 1) <> "" Then
Tabelle3.Cells(7 + i, 19) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 3, False)
Tabelle3.Cells(7 + i, 20) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 4, False)
Tabelle3.Cells(7 + i, 21) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 5, False)
End if
Next i
Thanks alot for your help & contribution!
I'm programmatically creating Excel workbooks, with a macro associated to a button, this macro is supposed to check if the values entered by the user in the worksheet are correct and to color the cells in green or red depending on the case.
The macro's code is in another Excel workbook and is added to the created workbooks with this code :
With newWorkBook.Worksheets(1).Buttons.Add(350, 115, 50, 41.25)
.Caption = "Vérifier la conformité"
.OnAction = "'" & ThisWorkbook.FullName & "'!check_FCM"
End With
Here is the macro's code part that doesn't work :
For i = 0 To col - 1
If (IsNumeric(Cells(29, i + 2).Value)) Then
If (Cells(29, i + 2).Value >= Cells(31, i + 2).Value And Cells(29, i + 2).Value <= Cells(32, i + 2)) Then
Range(Cells(29, i + 2).Address()).Interior.Color = RGB(0, 255, 0)
Else
Range(Cells(29, i + 2).Address()).Interior.Color = RGB(255, 0, 0)
isCorrect = False '
End If '
End If '
Next i '
The problem seems to be coming from the use of "Interior.Color=RGB(x,y,z)" because when I remove it I don't get a bug.
You can Unprotect and Protect sheet as follow:
Sheets("sheetname").Unprotect
For i = 0 To col - 1
If (IsNumeric(Cells(29, i + 2).Value)) Then
If (Cells(29, i + 2).Value >= Cells(31, i + 2).Value And Cells(29, i + 2).Value <= Cells(32, i + 2)) Then
Cells(29, i + 2).Interior.Color = RGB(0, 255, 0)
Else
Cells(29, i + 2).Interior.Color = RGB(255, 0, 0)
isCorrect = False
End If
End If
Next i
Sheets("sheetname").Protect
And also can use Cells object to change color. Check it. I made small modification to your code.
I was running a VBA code in Excel 2007. I got the above mention run/Application error of 1004.
My code is
Public Sub LblImport_Click()
Dim i As Long, j As Long
Dim vData As Variant, vCleanData As Variant, vFile As Variant, sMarket As String
Dim wbkExtract As Workbook, sLastCellAddress As String, month As String
Dim cnCountries As New Collection
Application.ScreenUpdating = False
' Get the name of the Dataview Extract file to transform and the market name
vFile = "D:\DRX\" & "Norvasc_Formatted.xlsx"
sMarket = "Hypertension"
ThisWorkbook.Worksheets("Control").Range("TherapeuticMarket").Value = "Hypertension"
' Clear all existing data from this workbook
ThisWorkbook.Worksheets("RawData").Cells.ClearContents
' Create labels in Raw Data Sheet
ThisWorkbook.Worksheets("RawData").Cells(1, 1).Value = "Therapy Market"
ThisWorkbook.Worksheets("RawData").Cells(1, 2).Value = "Country"
ThisWorkbook.Worksheets("RawData").Cells(1, 3).Value = "Brand"
ThisWorkbook.Worksheets("RawData").Cells(1, 4).Value = "Corporation"
ThisWorkbook.Worksheets("RawData").Cells(1, 5).Value = "Molecule"
' Open Dataview extract, copy and clean data
Set wbkExtract = Workbooks.Open(vFile)
i = 2
Do While wbkExtract.ActiveSheet.Cells(1, i).Value <> ""
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "TRX" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(1)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 10) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2), 3, 2)
End If
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "LCD" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 14) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(3), 3, 2)
End If
i = i + 1
Loop
wbkExtract.ActiveSheet.Cells(1, 1).EntireRow.Delete
vData = wbkExtract.ActiveSheet.Cells(1, 1).CurrentRegion.Value
wbkExtract.Close savechanges:=False
vCleanData = CleanRawData(vData, sMarket)
sLastCellAddress = ThisWorkbook.Worksheets("RawData").Cells(UBound(vCleanData, 1) + 1, UBound(vCleanData, 2)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ThisWorkbook.Worksheets("RawData").Range("A2:" & sLastCellAddress).Value = vCleanData
' Get List of Unique Countries
On Error Resume Next
For i = 1 To UBound(vCleanData, 1)
cnCountries.Add vCleanData(i, 2), vCleanData(i, 2)
Next i
On Error GoTo 0
ThisWorkbook.Worksheets("Market").Cells(1, 1).CurrentRegion.Clear
ThisWorkbook.Worksheets("Market").Cells(1, 1).Value = "Country"
ThisWorkbook.Worksheets("Market").Cells(1, 2).Value = "Group 1"
ThisWorkbook.Worksheets("Market").Cells(1, 3).Value = "Group 2"
ThisWorkbook.Worksheets("Market").Cells(1, 4).Value = "Group 3"
ThisWorkbook.Worksheets("Market").Cells(1, 5).Value = "Group 4"
ThisWorkbook.Worksheets("Market").Range("A1:G1").Font.Bold = True
For i = 1 To cnCountries.Count
ThisWorkbook.Worksheets("Market").Cells(i + 1, 1).Value = cnCountries.Item(i)
Next i
End Sub
Sounds like a broken code cache.
I've seen errors happen like this before in older format (xls) workbooks and it can be a sign of problems in the file overall.
Try the compile option suggested by #Scott Holtzman first. In some cases I've seen the recompile not work and if that happens just force a compile by making a change to the code. A trivial change is enough usually.
If that doesn't work then (to help disagnose a corruption issue) try copying the code into a new workbook and see what happens there. If it runs in the new sheet then I wouldn't waste more time on it and just rebuild the sheet, trust me it'll be quicker than messing about troublshooting the one you have.