Going through a range (Looping?)

[Chunk]

Greetings everyone,

2107721076

Here is what I am attempting to do.

In my main workbook (where the code resides) I want to go through the Lookuplist, and every project that is Active ("Y") to update event dates from another workbook that contains the current event dates. The code that I am currently using updates the first active project.


Sub change()
Dim ws As Worksheet
Dim WB As Workbook
Dim FindString As String
Dim rng As Range
Dim Daterng As Range
Dim KErng As Range

Dim Mainrng As Range
Dim KEUprng As Range
Dim Frng As Range
Dim cel As Range
Set ws = ThisWorkbook.Worksheets("LookUpList")
Set Frng = Nothing
Worksheets("LookUpList").Activate
FindString = "Y"

If Trim(FindString) <> "" Then
Set rng = ws.Range("D2:D30").Find( _
What:=(FindString), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rng Is Nothing Then
Set WB = Workbooks.Open("C:\Event Dates\Event_HA" & rng(1, -2) & ".csv")
Set Daterng = Range("B2:B40")
Daterng.Value = Application.Trim(Daterng)
Set KErng = Range("A2:A40")
KErng.Value = Application.Trim(KErng)
Set Mainrng = ThisWorkbook.Worksheets(rng(1, -2) & "_N").Range("A2:A11")
Set KEUprng = WB.Worksheets("KElist_HA" & rng(1, -2)).Range("A2:A40")
End If
For Each Frng In Mainrng
Set cel = KEUprng.Find(Frng)
If Not cel Is Nothing Then
Frng.Offset(, 1).Value = cel.Offset(, 1).Value
Set cel = Nothing
End If
Next Frng
WB.Close

End If
Call mod_Data_View.KE_Change 'updates userform text boxes

End Sub



I've tried inserting a loop in and the results were disastrous. Attached are two workbooks, Main and Event.

Note: All projects are NOT alike. Some projects have more events than others.

Note: The Event file almost always contains more events than are tracked in the Main workbook

Any ideas are greatly appreciated. Thanks in advance.

[p45cal]

A guess:
Sub change2()
Dim ws As Worksheet
Dim WB As Workbook
Dim FindString As String
Dim rng As Range
Dim Daterng As Range
Dim KErng As Range

Dim Mainrng As Range
Dim KEUprng As Range
Dim Frng As Range
Dim cel As Range
Set ws = ThisWorkbook.Worksheets("LookUpList")
Set Frng = Nothing
Worksheets("LookUpList").Activate
FindString = "Y"

If Trim(FindString) <> "" Then
For Each rng In ws.Range("D2:D30").Cells
If Application.Trim(rng.Value) = FindString Then
Set WB = Workbooks.Open("C:\Event Dates\Event_HA" & rng(1, -2) & ".csv")
Set Daterng = Range("B2:B40")
Daterng.Value = Application.Trim(Daterng)
Set KErng = Range("A2:A40")
KErng.Value = Application.Trim(KErng)
Set Mainrng = ThisWorkbook.Worksheets(rng(1, -2) & "_N").Range("A2:A11")
Set KEUprng = WB.Worksheets("KElist_HA" & rng(1, -2)).Range("A2:A40")
End If
For Each Frng In Mainrng
Set cel = KEUprng.Find(Frng)
If Not cel Is Nothing Then
Frng.Offset(, 1).Value = cel.Offset(, 1).Value
Set cel = Nothing
End If
Next Frng
Next rng
WB.Close

End If
Call mod_Data_View.KE_Change 'updates userform text boxes

End Sub

[snb]

This should be sufficient:


Sub M_snb()
sn= sheets("LookUpList").cells(1).currentregion

for j=1 to ubound(sn)
if sn(j,3)="Y" then
with getobject("C:\Event Dates\Event_HA" & sn(j,1) & ".csv"}
sheets(sn(j,1)).range("A2:B40")=.sheets(1).range("A2:B40").value
.close 0
end with
end if
next
End Sub

[Chunk]

snb,

I am receiving a "Subscript out of range" error at

With getobject("C:\Event Dates\Event_HA" & sn(j,1) & ".csv")
I failed to mention earlier that each project has it's own Event workbook and the Main and Event workbooks are in different locations. I don't know if that makes a difference.

Chunk

[Chunk]

p45cal,

I am getting a "Object required" error at

For Each Frng In Mainrng
Any ideas? Thanks in advance.

Chunk

[snb]

Analyse the code.

[p45cal]

p45cal,

I am getting a "Object required" error at

For Each Frng In Mainrng
Any ideas? Thanks in advance.

Chunk

All I have done is tweak your original code, which will have the propensity to do the same thing.
I suspect (because I haven't examined the code closely) that moving one End IF might do the trick, changing:

For Each Rng In ws.Range("D2:D30").Cells
If Application.Trim(Rng.Value) = FindString Then
Set WB = Workbooks.Open("C:\Event Dates\Event_HA" & Rng(1, -2) & ".csv")
Set Daterng = Range("B2:B40")
Daterng.Value = Application.Trim(Daterng)
Set KErng = Range("A2:A40")
KErng.Value = Application.Trim(KErng)
Set Mainrng = ThisWorkbook.Worksheets(Rng(1, -2) & "_N").Range("A2:A11")
Set KEUprng = WB.Worksheets("KElist_HA" & Rng(1, -2)).Range("A2:A40")
End If '<<<<< this one
For Each Frng In Mainrng
Set cel = KEUprng.Find(Frng)
If Not cel Is Nothing Then
Frng.Offset(, 1).Value = cel.Offset(, 1).Value
Set cel = Nothing
End If
Next Frng
Next Rng
to:

For Each Rng In ws.Range("D2:D30").Cells
If Application.Trim(Rng.Value) = FindString Then
Set WB = Workbooks.Open("C:\Event Dates\Event_HA" & Rng(1, -2) & ".csv")
Set Daterng = Range("B2:B40")
Daterng.Value = Application.Trim(Daterng)
Set KErng = Range("A2:A40")
KErng.Value = Application.Trim(KErng)
Set Mainrng = ThisWorkbook.Worksheets(Rng(1, -2) & "_N").Range("A2:A11")
Set KEUprng = WB.Worksheets("KElist_HA" & Rng(1, -2)).Range("A2:A40")
For Each Frng In Mainrng
Set cel = KEUprng.Find(Frng)
If Not cel Is Nothing Then
Frng.Offset(, 1).Value = cel.Offset(, 1).Value
Set cel = Nothing
End If
End If '<<<<< to here
Next Frng
Next Rng

[Chunk]

snb,

I went through the code, it's almost there. The problem is that it is transferring all dates from the Event workbook.

The one thing I need it to do is compare the Events (column A) to the Main.project sheet (column A) and only transfer the dates of the events existing in the Main workbook. Does that make sense?

Chunk

[Chunk]

Thank you guys for your help thus far.

I'm looking back at my explanation and don't think it was up to par, so I'm going to try again.

From a userform (UserForm2) from the main workbook(Main.xlsx), the user executes a button that I want to follow the following steps:

NOTE: The Main.xlsx workbook contains the LookUpList, and a sheet for each Project

1) Loop through the LookUpList, column C, for active projects (Y)

2) When an active project is found, it will open, then format that project's workbook (Proj1.xlsx, Proj2.xlsx, etc)

3) Next I need to compare the following two columns:
The opened Project workbook column A
The Main workbook, project sheet column A

4) Any time that "Event, column A" = "Main, project sheet, column A", I need the date from Event to replace the date in Main.

NOTE: In my original file I am only concerned with columns A and B. I have added column C (the dates to change to) for convenience of what the values should be.

I hope this makes sense. If it doesn't please let me know and I will try to clarify.


Sub change()
Dim WB As Workbook
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim rngCSVdt As Range
Dim rngMain As Range
Dim rngCSV As Range
Dim Findstring As String

Worksheets("LookUpList").Activate
Set rng = Range("D2:D30")
For Each cell In rng 'Loop through LookUpList for Active Projects ("Y")
If cell.Value = "Y" Then
Set WB = Workbooks.Open("C:\Events\Evt" & cell(1, 2) & ".xlsx") 'Open active projects xlsx file
Set rngCSVdt = Range("B2:B40")
Set rngCSV = Range("A2:A40")
rngCSVdt.Value = Application.Trim(rngCSVdt) 'TRIM dates on xlsx file
Columns("B:B").Select
Selection.NumberFormat = "mm/dd/yyyy" 'Works fine to this point

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ThisWorkbook.Worksheets(rng(1, -2)).Activate
Set rngMain = ThisWorkbook.Worksheets(rng(1, -2)).Range("A2:A11")
For Each rngCSV In ActiveSheet.Range("A2:A11")
rngMain.Offset(, 1).Value = rngCSV.Offset(, 1).Value
Next rngCSV
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
Next cell
End Sub



Thanks for your time.

Chunk

[snb]

Do not use 'select' or 'Activate' in VBA !

[Chunk]

snb,

So I went through the code and eliminated anywhere I had "select" or "activate". Here is the code I now have.

Sub change()
Dim WB As Workbook
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim rngCSVdt As Range
Dim rngMain As Range
Dim rngCSV As Range
Dim Findstring As String




Set rng = Worksheets("LookUpList").Range("D2:D30")



For Each cell In rng

If cell.Value = "Y" Then

Set rngMain = Workbooks("Main.xlsx").Worksheets(cell(1, 2) & "_N").Range("A2:A40")

Set WB = Workbooks.Open("("C:\Events\Evt\Evt" & cell(1, 2) & ".csv")

Set rngCSV = Range("A2:A40")

rngCSV.Value = Application.Trim(rngCSV)

Set rngCSVdt = Range("B2:B40")

With rngCSVdt

.Value = Application.Trim(rngCSVdt)

.NumberFormat = "mm/dd/yyyy"

End With

For Each rngCSV In rngMain

If rngCSV.Text = rngMain.Text Then

rngMain.Offset(, 1).Text = rngCSV.Offset(, 1).Text

Else

MsgBox "Value not found"

End If

Next rngCSV

WB.Close
End If



Next cell

End sub

I have stepped through the code multiple times and found an issue. The "rngMain" is reading as "Null" so with my limited experience I am assuming that rngCSV has nothing to compare to? Any ideas? Thanks in advance.

Chunk

[Chunk]

Thank you all for your time,

With a little help from a work friend I found where I erred. In addition thanks for the advice with select and activate.

Here is the code I ended up with



Sub change()
Dim WB As Workbook
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim rngCSVdt As Range
Dim rngMain As Range
Dim rngCSV As Range
Dim c1 As Range
Dim c2 As Range

Set rng = Worksheets("LookUpList").Range("D2:D30")
For Each cell In rng

If cell.Value = "Y" Then

Set rngMain = Workbooks("Main.xlsx").Worksheets(cell(1, 2) & "_N").Range("A2:A40")

Set WB = Workbooks.Open("("C:\Events\Evt\Evt" & cell(1, 2) & ".csv")

Set rngCSV = Range("A2:A40")

rngCSV.Value = Application.Trim(rngCSV)

Set rngCSVdt = Range("B2:B40")
With rngCSVdt

.Value = Application.Trim(rngCSVdt)

.NumberFormat = "mm/dd/yyyy"

End With

For Each c1 In rngMain '<----------- Added here
If c1 <> "" Then
For Each c2 In rngCSV

If c1 = c2 Then
c1.Offset(, 1) = c2.Offset(, 1)
End If
Next
End If
Next

WB.Close SaveChanges:=False
End If
Next cell
End Sub


Hope this helps

Regards,

Chunk