Kopiere række fra ark løbende..
Følgende makro er blevet rettet en smule til efter den virkede efter hensigten i spm:http://www.computerworld.dk/eksperten/spm/1006650
Sub åbne_ark_i_samme_mappe()
' Optimering af åbning og gennemløb
Dim cal As Integer
cal = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Definer variable
Dim wkbMaster As Workbook
Dim wkbInput As Workbook
Dim strMappe As String
Dim strFil As String
Dim ranRæk As Range
Dim strLønartID As String
' Udfyld variable
Set wkbMaster = ActiveWorkbook
strMappe = wkbMaster.Names("regnskabsfiler").RefersToRange.Value
strFil = Dir(strMappe & "\*.*")
strLønartID = wkbMaster.Sheets("sheet1").Range("B2").Value
Do While strFil <> ""
' Laver gennemløb af alle filer i mappen defineret i B1
Set wkbInput = Workbooks.Open(strMappe & "\" & strFil, False, True)
' Kopierer hver linje der i kolonne 6 (f) har samme nr som står i B2 i vognkortfilen
For Each ranRæk In Range(wkbInput.Worksheets("Workings").Range("A20"), wkbInput.Worksheets("Workings").Range("A1").Offset(wkbInput.Worksheets("workings").Rows.Count - 1, 0).End(xlUp)).Cells
If ranRæk.Offset(, 5).Value = strLønartID Then
ranRæk.EntireRow.Copy wkbMaster.Worksheets("Sheets1").Range("A5").Offset(wkbMaster.Worksheets("Sheets1").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next
wkbInput.Close
strFil = Dir
Loop
' Afslut optimering og "almindeliggøre" Excel kalkulationer
Application.Calculation = cal
Application.ScreenUpdating = True
End Sub
Min udfordring er at den går i stå hvor ranRæk værdien er "NDS" - det undrer mig meget, jeg ville have troet den var en "adresse", men det kan være jeg har gjort noget galt i udtrykket:
For Each ranRæk In Range(wkbInput.Worksheets("Workings").Range("A20"), wkbInput.Worksheets("Workings").Range("A1").Offset(wkbInput.Worksheets("workings").Rows.Count - 1, 0).End(xlUp)).Cells
If ranRæk.Offset(, 5).Value = strLønartID Then
ranRæk.EntireRow.Copy wkbMaster.Worksheets("Sheets1").Range("A5").Offset(wkbMaster.Worksheets("Sheets1").Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Kan nogen af jer gennemskue det?