View Full Version : [SOLVED:] Going through a range (Looping?)
Chunk
11-28-2017, 09:41 AM
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
11-28-2017, 10:57 AM
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
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
11-29-2017, 05:54 AM
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
11-29-2017, 06:00 AM
p45cal,
I am getting a "Object required" error at
For Each Frng In Mainrng
Any ideas? Thanks in advance.
Chunk
p45cal
11-29-2017, 07:40 AM
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
11-29-2017, 11:07 AM
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
12-19-2017, 05:28 AM
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
Do not use 'select' or 'Activate' in VBA !
Chunk
12-19-2017, 11:34 AM
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
12-21-2017, 05:35 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.