Loop Macro
Hello All,
Im trying to modify a macro I've used in the past for another routine, but Im not having much luck and could use a little advice. Im basically looking to perform a Match and Copy.Cell.Offset.Value to another workbook. The first ActiveWorkbook is referenced as Oldbook. The Oldbook Row 5 is the column Im looking to match against Workbook 2 (FileName) Row 1 contents. I would like the Macro to evaluate/match each individual cell value in rows 1 through 200 (Oldbook). If there is a Match in the FileName book, Id like to write Oldbook values for Row 7, 8, 10 to rows 2, 3 and 4 in FileName book for that particular match (and continue down the worksheet). I know this request might be a bit confusing, but Im hoping this along with the Macro might shed additional light on the basics of my request. Thanks for your review and thoughts €“ Roger Sub fyCompare() Dim Msg As String Dim Path As String Dim FileName1 As String Dim FileName2 As String On Error Resume Next Application.ScreenUpdating = False Msg = "Unable to find" Path = "C:\Documents and Settings\Roger\Desktop\" Filename = "Events.xls" Oldbook = ActiveWorkbook.Name Err = 0 If WorkbookIsOpen(Filename) = False Then Workbooks.Open Filename:=Path & Filename Else Workbooks(Filename).Activate End If If Err < 0 Then MsgBox Msg & Path & Filename, vbCritical, "Error" Exit Sub End If Workbooks(Filename).Activate For r = 1 To 200 '<<<<<< need macro that steps down and 'evaluates each match and writes to offset cells End If Next r Workbooks(Filename).Close Application.ScreenUpdating = True End Sub Private Function WorkbookIsOpen(wbName) As Boolean ' Returns TRUE if the workbook is open Dim X As Workbook On Error Resume Next Set X = Workbooks(wbName) If Err = 0 Then WorkbookIsOpen = True _ Else: WorkbookIsOpen = False On Error GoTo 0 End Function |
Loop Macro
Roger
This is not what you asked for but it is late. The thing is that you can not copy offsets - you must specify the cell. The following rounds a time Column A, copies the rounded time to a dynamic list or rather places this value into another cell. A lot of code establishes the original range then works on that to to use cell.offset Sub wghtdAvg1() Dim col As Integer, startR As Integer, r As Long Dim CuProd As Double, CuQty As Long, lr As Long, l As Long Dim row As Long, i As Long, TCol As Integer, lst, rng As Range 'Set rng = Selection l = Selection.Rows.Count r = ActiveCell.row - 1: startR = ActiveCell.row: TCol = ActiveCell.Column lr = startR + l - 1: col = TCol + 4: row = r For i = startR To lr d = Int(Cells(i, TCol) * 1440) * 1 / 1440 'strip seconds from time 2:45:20 to 2:45 Set lst = Range(Cells(startR, col), Cells(row, col)) x = Application.Match(d, lst, 0) If IsError(x) Then row = row + 1 Cells(row, col) = d 'enter time in analysis column CuProd = Cells(i, TCol + 1) * Cells(i, TCol + 2) 'rate * Qty CuQty = Cells(i, TCol + 2) 'add qty Cells(row, col + 1) = Cells(i, 2) 'enter qty in analysis Else 'repeat while time to minute remains the same CuQty = CuQty + Cells(i, TCol + 2) CuProd = CuProd + Cells(i, TCol + 1) * Cells(i, TCol + 2) Cells(row, col + 1) = Application.Round(CuProd / CuQty, 3) End If Next i End Sub I did this for someone the other day, hope you can make it work for you. Peter "Roger" wrote: Hello All, Im trying to modify a macro I've used in the past for another routine, but Im not having much luck and could use a little advice. Im basically looking to perform a Match and Copy.Cell.Offset.Value to another workbook. The first ActiveWorkbook is referenced as Oldbook. The Oldbook Row 5 is the column Im looking to match against Workbook 2 (FileName) Row 1 contents. I would like the Macro to evaluate/match each individual cell value in rows 1 through 200 (Oldbook). If there is a Match in the FileName book, Id like to write Oldbook values for Row 7, 8, 10 to rows 2, 3 and 4 in FileName book for that particular match (and continue down the worksheet). I know this request might be a bit confusing, but Im hoping this along with the Macro might shed additional light on the basics of my request. Thanks for your review and thoughts €“ Roger Sub fyCompare() Dim Msg As String Dim Path As String Dim FileName1 As String Dim FileName2 As String On Error Resume Next Application.ScreenUpdating = False Msg = "Unable to find" Path = "C:\Documents and Settings\Roger\Desktop\" Filename = "Events.xls" Oldbook = ActiveWorkbook.Name Err = 0 If WorkbookIsOpen(Filename) = False Then Workbooks.Open Filename:=Path & Filename Else Workbooks(Filename).Activate End If If Err < 0 Then MsgBox Msg & Path & Filename, vbCritical, "Error" Exit Sub End If Workbooks(Filename).Activate For r = 1 To 200 '<<<<<< need macro that steps down and 'evaluates each match and writes to offset cells End If Next r Workbooks(Filename).Close Application.ScreenUpdating = True End Sub Private Function WorkbookIsOpen(wbName) As Boolean ' Returns TRUE if the workbook is open Dim X As Workbook On Error Resume Next Set X = Workbooks(wbName) If Err = 0 Then WorkbookIsOpen = True _ Else: WorkbookIsOpen = False On Error GoTo 0 End Function |
All times are GMT +1. The time now is 08:01 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com