I am currently trying to input data from an export sheet from MS Project. I have produced the data on worksheet1 and I am attempting to reproduce what I have created in an excel page.
I am at the early stages and I have written some code. I have looked up the error and I cannot see where I am going wrong. To start with, i just want to input a sub section of the data into an array so I can manipulate it later on.
The debug is highlighting the following line:
If Worksheets("Sheet1").Cells(i, 9).Value = Worksheets("Sheet2").Cells(j, 1).Value Then
I am a C++ programmer so I thought my array manipulation was ok but this is my second day on VBA so take it easy on me!
Code Below:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
Dim Arr(2, 11) As Variant
j = 5
For i = 1 To 10
If Worksheets("Sheet1").Cells(i, 9).Value = Worksheets("Sheet2").Cells(j, 1).Value Then Arr(0, i) = Worksheets("Sheet1").Cells(i, 4).Value And Arr(1, i) = Worksheets("Sheet1").Cells(i, 6).Value And Arr(2, i) = Worksheets("Sheet1").Cells(i, 7).Value
Next i
MsgBox ("Value in Array index 2,2 : " & Arr(2, 2))
End Sub
Does this work:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
Dim Arr(2, 11) As Variant
j = 5
For i = 1 To 10
If Worksheets("Sheet1").Cells(i, 9).Value = Worksheets("Sheet2").Cells(j, 1).Value Then
Arr(0, i) = Worksheets("Sheet1").Cells(i, 4).Value
Arr(1, i) = Worksheets("Sheet1").Cells(i, 6).Value
Arr(2, i) = Worksheets("Sheet1").Cells(i, 7).Value
End If
Next i
MsgBox ("Value in Array index 2,2 : " & Arr(2, 2))
End Sub
The "IF" statement didn't need those "ANDs" for when the statement is true. That might have been one of the issues. In VB (not sure about C++), when your IF statement is TRUE, everything after Then will occur, until the End If (or ElseIf), no need to say "do this, AND do this, AND do this...", it's just "Do this, this, this, this".
If ThisWorkbook.Worksheets("Sheet1").Cells(i, 9).Value = ThisWorkbook.Worksheets("Sheet2").Cells(j, 1).Value Then
Arr(0, i) = Worksheets("Sheet1").Cells(i, 4).Value
Arr(1, i) = Worksheets("Sheet1").Cells(i, 6).Value
Arr(2, i) = Worksheets("Sheet1").Cells(i, 7).Value
End If
Replace your long line of IF code with this. You also forgot to close your IF statement, and the AND statements are not needed, it just executes all code after THEN until it hits and END IF
Related
Credit for code is for few editors in Mr . Excel forum. This code works like a charm, but I need it to copy the entire row of the new data, rather than only values from column A. Now I tried to play with true and false statements and etc. but to no avail, I believe it is out of my scope and id like so suggestions or assistance how to achieve my mission. I have simple values, no formulas, just some named columns and thousands of rows in original file and extract file.
Sub AddMissingItems()
Dim Dic As Object
Dim Arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long
Dim c as long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
c = .Cells(1, Columns.Count).End(xlToLeft).Column
Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
For i = 1 To UBound(Arr, 1)
If Dic.exists(Arr(i, 1)) = False Then
Dic.Add (Arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile").Worksheets("Sheet1")
Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
ReDim outArr(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
If Dic.exists(Arr(i, 1)) = False Then
k = k + 1
outArr(k, 1) = Arr(i, 1)
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k).Value = outArr
k = 0
End If
End Sub
Tried adding Entirerow statement to several places, but to no avail.
Please, try the next adapted code. I commented where I input new variables/code lines:
Sub AddMissingItems()
Dim Dic As Object, Arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long, c As Long
Dim r As Long, j As Long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
Arr = .Range("A1:A" & .Range("A" & .rows.count).End(xlUp).row).Value
For i = 1 To UBound(Arr, 1)
If Dic.Exists(Arr(i, 1)) = False Then
Dic.Add (Arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile.xlsx").Worksheets("Sheet1")
c = .cells(1, Columns.count).End(xlToLeft).column
r = .Range("A" & .rows.count).End(xlUp).row 'calculate the last row in A:A, too
Arr = .Range("A1", .cells(r, c)).Value 'place in the array all existing columns
ReDim outArr(1 To UBound(Arr), 1 To c) 'extend the redimmed array to all columns
For i = 1 To UBound(Arr)
If Dic.Exists(Arr(i, 1)) = False Then
k = k + 1
For j = 1 To c 'iterate between all array columns:
outArr(k, j) = Arr(i, j) 'place the value from each column
Next j
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & rows.count).End(3).row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k, UBound(Arr, 2)).Value = outArr 'resize by columns, too
k = 0
End If
End Sub
Please, send some feedback after testing it.
I have a two dimensional array comprised of "trouble" words and phrases in the first dimension and the comments I frequently make in the second dimension. I seem to be lost at how to select the text that matches the first dimension and add the comment using the text from the second dimension. Any ideas?
Sub findtrouble()
Dim i As Integer
Dim j As Integer
Dim oRng As Word.Range
Dim MyArray(1, 4) As String
MyArray(0, 0) = "Trouble0"
MyArray(0, 1) = "Trouble1"
MyArray(0, 2) = "Trouble2"
MyArray(0, 3) = "Trouble3"
MyArray(1, 0) = "Comment0"
MyArray(1, 1) = "Comment1"
MyArray(1, 2) = "Comment2"
MyArray(1, 3) = "Comment3"
For j = 0 To 4
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearAllFuzzyOptions
.ClearFormatting
.Text = MyArray(0, j)
While .Execute
oRng.Select
ActiveDocument.Comments.Add oRng, MyArray(1, j)
Wend
End With
Debug.Print "Find: " & MyArray(0, j) & " add cmt box w/ "; MyArray(1, j)
Next j
End Sub
The code in the question does insert one comment for me, but that's all. It's because oRng isn't being reset. Compare the code in the question to that below.
In this code, after Find.Execute is successful and the comment added the range is collapsed to it endpoint (after the found term) then the end extended to the end of the document. In this way, the next time the term is searched it looks only in what follows the first term.
It's also important when looping in Find to set the Find.Wrap to wdFindStop to avoid going into an "infinite loop" (so that Find doesn't start again at the top of the document).
Sub findtrouble()
Dim i As Integer
Dim j As Integer
Dim oRng As Word.Range
Dim MyArray(1, 4) As String
MyArray(0, 0) = "Trouble0"
MyArray(0, 1) = "Trouble1"
MyArray(0, 2) = "Trouble2"
MyArray(0, 3) = "Trouble3"
MyArray(1, 0) = "Comment0"
MyArray(1, 1) = "Comment1"
MyArray(1, 2) = "Comment2"
MyArray(1, 3) = "Comment3"
For j = 0 To 4
Set oRng = ActiveDocument.Content
With oRng.Find
.ClearAllFuzzyOptions
.ClearFormatting
.text = MyArray(0, j)
.wrap = wdFindStop
While .Execute
oRng.Select
ActiveDocument.Comments.Add oRng, MyArray(1, j)
oRng.Collapse wdCollapseEnd
oRng.End = ActiveDocument.content.End
Wend
End With
Debug.Print "Find: " & MyArray(0, j) & " add cmt box w/ "; MyArray(1, j)
Next j
End Sub
As per #Cindy Meisters' comment the posted code does work (even with the indexing error in the for loop). The code below is the same rewritten to use a scripting.dictionary
Sub testfindtrouble()
findtrouble ActiveDocument.Range
End Sub
Sub findtrouble(this_range As Word.Range)
Dim my_lookup As scripting.Dictionary
Dim my_troubles As Variant
Dim my_trouble As Variant
Dim my_range As Word.Range
' see https://stackoverflow.com/questions/53317548/how-to-delete-a-section-using-excel-vba-to-create-a-word-document/53322166?noredirect=1#comment93559248_53322166
Set my_lookup = New scripting.Dictionary
With my_lookup
.Add key:="Trouble0", item:="Comment0"
.Add key:="Trouble1", item:="Comment1"
.Add key:="Trouble2", item:="Comment2"
.Add key:="Trouble3", item:="Comment3"
End With
my_troubles = my_lookup.Keys
' Avoid the off by 1 error (j=0 to 4 is 5 items not the 4 you declared in the array
For Each my_trouble In my_troubles
Set my_range = this_range.Duplicate
With my_range
With .Find
.ClearAllFuzzyOptions
.ClearFormatting
.text = my_trouble
.Execute
End With
Do While .Find.Found
Debug.Print "Find: " & my_trouble & " add cmt box w/ "; my_lookup.item(my_trouble)
.Comments.Add .Duplicate, my_lookup.item(my_trouble)
.Collapse Direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
.Find.Execute
Loop
End With
Next
End Sub
Please see the attachment for understanding the output of my query (I have mentioned header in the image for your understanding by in actual, header is blank for the output).
My code runs only for first iteration of k and then I get the error "Subscript out of range at the line mentioned below. Also, my remove duplicates is not giving the required output in the code. is it because of blank spaces or what and how can I resolve these two issues?
I am using arrays for the very first time.
Dim MoNameArr
Dim arr()
Dim ColLtrg, ColLtrgp, GPLLastCol, GPLLastRow as Long
i = 0
ReDim arr(0)
With wsg
For k = 2 To GPLLastRow
.Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
i = k - 2
arr(i) = .Cells(k, 2).Value 'Subscript out of range error
.Cells(k, GPLLastCol + 2).Value = arr(i)
ReDim Preserve arr(i)
End If
Next k
ColLtrg = Replace(.Cells(1, GPLLastCol + 2).Address(True, False), "$1", "")
.Range(ColLtrg & "1:" & ColLtrg & GPLLastRow).RemoveDuplicates Columns:=1, Header:=xlNo
MoNameArr = .Range("AD1:AD" & GetLastRow(wsg, GPLLastCol + 2))
End With
For Each Item In MoNameArr
'Do something
Next Item
Public Function GetLastCol(ByVal ws As Worksheet, rowNum As Long) As Long
With ws
GetLastCol = .Cells(rowNum, Columns.Count).End(xlToLeft).Column
End With
End Function
Public Function GetLastRow(ByVal ws As Worksheet, colNum As Long) As Long
With ws
GetLastRow = .Cells(Rows.Count, colNum).End(xlUp).Row
End With
End Function
The subscript out of range error is most likely from how you defined your array to the Application. I feel pretty confident that when you're getting that error, i <> 0.
Note:
When using ReDim Preserve arr(i), you need to declare this before attempting to put a variable in arr(i). Also, since i is based off of k, which is related to the cell reference, your array will result in a number of empty item slots in between the values you decide to keep.
Explanation
In this line:
ReDim arr(0)
You are telling the Application to define arr as a single dimension array with an upper boundary of 0 Since the default lower boundary is usually 0, as well; you are essentially telling the Application to define the array with room for 1 object.
Which would be accessed via the codearr(0)
If you had used the following line:
ReDim arr(1 to 10)
You would be telling the Application to define the array as single-dimensional, with room for 10 objects, the first being accessed via arr(1) and the last via arr(10).
This next line would also define the array as single dimensional, with 10 objects:
ReDim arr(9)
However, this time, the first object can be accessed via arr(0) and the last via arr(9). (This is based on the assumption that you haven't declared in your vba that the default lower bound should be 1.)
You could define a two dimensional array like so:
ReDim arr(0 to 5, 0 to 15)
This array would hold 96 items. However, to access them, you would have to use code like arr(0,4) or arr(2,15).
Alternative Option
If I may recommend an alternative method, have you considered using a dictionary object instead of an array?
Since I do not know all that you may be doing with your data, this may not be the best solution. However, if you're main goal is to remove duplicate values from, and condense, a column, I think a dictionary should work rather well.
This Q/A on stackoverflow has some good basic information on dictionaries vs collections vs arrays.
The main reason I'm thinking dictionary, is because dictionary objects have an .Exists method in which you can pass a value (as a key) and see if the dictionary already has it. Then you can add any new items and ignore duplicate ones.
Assuming dict is a dictionary object and rng is the looping variable cell/range object you are checking, you could use the following code to collect a list of distinct values and counts:
For each rng in SomeRangeVariable
With dict
If .Exists(rng.Value) Then
.Items(rng.Value) = .Items(rng.Value) + 1
Else
.Add Key:=rng.Value, Item:=1
End If
End With
Next rng
You instantiate the zero-based 1-D array arr with a single element; e.g. arr(0 to 0).
On the first iteration of your loop, k is 2 and i = k - 2 so i is zero. There is room in the array for the .Cells(k, 2) value if the conditions are met.
The ReDim statement does nothing here since i is zero and ubound(arr) is already zero.
On the next iteration and everyone after until the condition is met, ubound(arr) is still zero but k has grown and since i is based on k, it grows as well. Any attempt to put the .Cells(k, 2) value into arr at position i will result in 'Subscript out of range'.
Solution: Redim with Preserve before attempting to populate the array.
For k = 2 To GPLLastRow
.Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
i = k - 2
ReDim Preserve arr(i)
arr(i) = .Cells(k, 2).Value 'Subscript not out of range anymore
.Cells(k, GPLLastCol + 2).Value = arr(i)
End If
Next k
Thank you so much Jeeped and Mistella for in-depth explanation and for making me realise loop-holes in my code. I am now able to do it using 2 ways. One with arrays and one without arrays.Can't say if anyone of these is better than the other but they both work for me.I will try the dictionary method also later.
'Method using arrays/Redim preserve
i = 0
With wsg
For k = 2 To GPLLastRow
On Error Resume Next 'For handling #N/A values
.Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
ReDim Preserve arr(i)
arr(i) = .Cells(k, 2).Value 'Subscript not out of range anymore
.Cells(i + 1, GPLLastCol + 2).Value = arr(i)
i = i + 1
End If
On Error GoTo 0
Next k
ColLtrgp = Replace(.Cells(1, GPLLastCol + 1).Address(True, False), "$1", "")
ColLtrg = Replace(.Cells(1, GPLLastCol + 2).Address(True, False), "$1", "")
.Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2)).RemoveDuplicates Columns:=1, Header:=xlNo
MoNameArr = .Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2))
End With
'Method without using arrays/Redim preserve
i = 1
With wsg
For k = 2 To GPLLastRow
On Error Resume Next
.Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
.Cells(i, GPLLastCol + 2).Value = .Cells(k, 2).Value
i = i + 1
End If
On Error GoTo 0
Next k
ColLtrgp = Replace(.Cells(1, GPLLastCol + 1).Address(True, False), "$1", "")
ColLtrg = Replace(.Cells(1, GPLLastCol + 2).Address(True, False), "$1", "")
.Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2)).RemoveDuplicates Columns:=1, Header:=xlNo
MoNameArr = .Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2))
End With
In worksheet wsb,I am trying to copy column B and Column having ParName in header and pasting it to columns B & H respectively of worksheet wso. The problem is It's running only for first Item and also for the first matched value of i for that item and not for all the matched item-i values.
Dim ws, wsa, wsb, wsc, wso As Worksheet
Dim index1b, LastRow, MOLastRow, wsoLastRow As Long
Dim ColLtr1b As Variant
Dim MoNameArr
Set wsb = Workbooks(Y).Sheets("REF")
wsb.Activate
LastRow = GetLastRow(wsb, 2)
Arr = Array("Abc", "Def")
Set wso = Workbooks(W).Sheets("Output")
For Each Item In Arr
For i = 2 To LastRow
If Cells(i, 2).Value = Item Then
wsb.Activate
ParName = wsb.Cells(i, 3).Value
Set wsc = Workbooks(M).Sheets(Item)
wsc.Activate
index1b = Application.Match(ParName, wsc.Rows(1), 0)
If Not IsError(index1b) Then
ColLtr1b = Replace(wsc.Cells(1, index1b).Address(True, False), "$1", "")
MOLastRow = wsc.Cells(Rows.Count, 2).End(xlUp).Row
Range("B2:B" & GetLastRow(wsc, 2)).Copy
wso.Activate
wsoLastRow = GetLastRow(wso, 2)
Range("B" & wsoLastRow + 1).Select
ActiveSheet.Paste
wsc.Activate
Range(ColLtr1b & "2:" & ColLtr1b & GetLastRow(wsc, 2)).Copy
wso.Activate
Range("H" & wsoLastRow + 1).Select
ActiveSheet.Paste
End If
End If
Next i
Next Item
Declare your variables like this:
Dim ws As Worksheet, wsa As worksheet, wsb as Worksheet
Dim wsc as Worksheet, wso As Worksheet
Dim index1b as Long, LastRow as Long, MOLastRow as Long, wsoLastRow As Long
Then start debugging with pressing F8. It goes line by line and you may see where is the problem in the nested loop. It can be in one of these 3:
you need to write Trim(Cells(i, 2)) in the If Cells(i, 2).Value = Item Then condition;
you are not calculating LastRow correctly;
you have On Error Resume Next somewhere in your code and you are entering an error w/o noticing;
I want to assign values to arrays from a sheet using loop
I tried using this but gives error "Subscript out of Range"
i=1
With ws
Do While i <= 40
ReDim Preserve WorkID(1 To i)
ReDim Preserve Work(1 To i)
ReDim Preserve ComposerName(1 To i)
WorkID(i) = Range("A" & i + 1).Value
Work(i) = Range("B" & i + 1).Value
ComposerName(i) = Range("C" & i + 1).Value
i = i + 1
Loop
End With
I tried both ways to initialize but none of them worked
Initialize Type 1
Dim WorkID() As Variant
Dim Work() As Variant
Dim ComposerName() As Variant
Initialize Type 2
Dim WorkID(1 to 40) As Variant
Dim Work(1 to 40) As Variant
Dim ComposerName(1 to 40) As Variant
Also I tried without Redim as well like this but nothing worked:
i=1
With ws
Do While i <= 40
WorkID(i) = Range("A" & i + 1).Value
Work(i) = Range("B" & i + 1).Value
ComposerName(i) = Range("C" & i + 1).Value
i = i + 1
Loop
End With
Full Sub here :
Option Explicit
Sub Join()
Dim WorkID() 'Stores the workID from Works Sheet
Dim Work() 'Stores the work from Works Sheet
Dim ComposerName() 'Stores the composer from Works Sheet
Dim ConductorID() 'Stores the ConductorID from Conductors Sheet
Dim ConductorNames() 'Stores Conductor Names from Conductors Sheet
Dim CDWorkID() 'Stores CDWorkID from CD Sheet
Dim CDCondID() 'Stores CDConductor ID from CD Sheet
Dim i, j, k, m As Long
Dim ws, wcon, wcd, wj As Worksheet
Set ws = Sheets("Works")
Set wcon = Sheets("Conductors")
Set wcd = Sheets("CDs")
Set wj = Sheets("Join")
i = j = k = 1 'Initalize
ws.Activate
Do While i <= 40
ReDim Preserve WorkID(1 To i)
ReDim Preserve Work(1 To i)
ReDim Preserve ComposerName(1 To i)
WorkID(i) = Range("A" & i + 1).Value
Work(i) = Range("B" & i + 1).Value
ComposerName(i) = Range("C" & i + 1).Value
i = i + 1
Loop
wcon.Activate
Do While j <= 10
ReDim Preserve ConductorID(1 To j)
ReDim Preserve ConductorNames(1 To j)
ConductorID(j) = Range("A" & j + 1).Value
ConductorNames(j) = Range("B" & j + 1).Value
j = j + 1
Loop
wcd.Activate
Do While k <= 132
ReDim Preserve CDWorkID(1 To k)
ReDim Preserve CDCondID(1 To k)
CDWorkID(k) = Range("A" & k + 1).Value
CDCondID(k) = Range("B" * k + 1).Value
k = k + 1
Loop
wj.Activate
For i = LBound(CDWorkID) To UBound(CDWorkID)
Range("F" & i) = CDWorkID(i)
Next i
End Sub
RedDim Preserve is generally an expensive operation since it involves allocating space for a larger array and moving contents from the old array. It is almost always a bad idea to use it inside of a loop. Instead -- determine ahead of time how big the arrays need to be and ReDim just once. If you don't know ahead of time, make them larger than needed and then use a ReDim Preserve after the loop to trim them down to size. In your case, I would Redim the arrays before entering for loops (or even -- why not Dim them the right size to begin with?). Also -- prefix each range with the appropriate worksheet variable rather than activating each in turn. Something like:
Sub Join()
Dim WorkID() 'Stores the workID from Works Sheet
Dim Work() 'Stores the work from Works Sheet
Dim ComposerName() 'Stores the composer from Works Sheet
Dim ConductorID() 'Stores the ConductorID from Conductors Sheet
Dim ConductorNames() 'Stores Conductor Names from Conductors Sheet
Dim CDWorkID() 'Stores CDWorkID from CD Sheet
Dim CDCondID() 'Stores CDConductor ID from CD Sheet
Dim i As Long
Dim ws, wcon, wcd, wj As Worksheet
Set ws = Sheets("Works")
Set wcon = Sheets("Conductors")
Set wcd = Sheets("CDs")
Set wj = Sheets("Join")
ReDim WorkID(1 To 40)
ReDim Work(1 To 40)
ReDim ComposerName(1 To 40)
For i = 1 To 40
WorkID(i) = ws.Range("A" & i + 1).Value
Work(i) = ws.Range("B" & i + 1).Value
ComposerName(i) = ws.Range("C" & i + 1).Value
Next i
ReDim ConductorID(1 To 10)
ReDim ConductorNames(1 To 10)
For i = 1 To 10
ConductorID(i) = wcon.Range("A" & i + 1).Value
ConductorNames(i) = wcon.Range("B" & i + 1).Value
Next i
ReDim CDWorkID(1 To 132)
ReDim CDCondID(1 To 132)
For i = 1 To 132
CDWorkID(k) = wcd.Range("A" & i + 1).Value
CDCondID(k) = wcd.Range("B" & i + 1).Value
Next i
For i = LBound(CDWorkID) To UBound(CDWorkID)
wj.Range("F" & i) = CDWorkID(i)
Next i
End Sub
Range("B" * k + 1).Value has a typo - you meant Range("B" & k + 1).Value. This makes the range raise an "type" error.
Eliminating this makes the code run without error - I suspect the error message is incorrect.
BTW, there is another pitfall (which does not lead to a runtime error, at least not for the code shown):
Dim i, j, k, m As Long
Dim ws, wcon, wcd, wj As Worksheet
will NOT declare i, j, kas Integer but as Variants. Same for ws, wcon, wcd which are variants and NOT worksheet objects.