Kopiere rækker ud fra værdier 2
I forbindelse med spørgsmål http://www.eksperten.dk/spm/834105har supertekst lavet nedenstående macro.
Jeg har nu samlet alle ark i samme fil via klippe/klistre og dataimport. Opgaven består nu i, at få macroen til at flettet ark1 med ark4 i ark7 og ark2 med ark5 i ark8 samt ark3 med ark6 i ark9 ud fra det som sker i kørslen mellem fil1 og fil2.
/dan
NB. kopi af regneark sendes gerne.
----------
Rem Version 2 - 15-06-08
Dim sti 'filer forventes at ligge i samme mappe
Dim fil1
Dim xlsFil2, fil2ræk, fil2SidsteRække
Sub findSumRækker()
Rem Koden indlægges i Fil1/Ark1
Application.ScreenUpdating = False
sti = findSti
Set fil1 = ActiveWorkbook.Sheets("excel")
åbnFil2
Rem Start Fil2/Ark1 søg Vnr
stRæk21 = 1
Rem Start-værdier for rækker i Fil2/Ark2
fil2ræk = 4
testDataFil1
xlsFil2.Sheets(2).Activate
xlsFil2.Sheets(2).Columns.AutoFit
lukFil2
Application.ScreenUpdating = True
MsgBox ("Kopiering er udført")
End Sub
Private Function findSti()
findSti = ActiveWorkbook.Path
If Right(findSti, 1) <> "\" Then
findSti = findSti + "\"
End If
End Function
Private Sub åbnFil2()
Set xlsFil2 = CreateObject("Excel.Application")
With xlsFil2
.Workbooks.Open sti + "fil2.xls"
' .Visible = True
End With
End Sub
Private Sub lukFil2()
xlsFil2.Application.DisplayAlerts = False
xlsFil2.Save
xlsFil2.Application.Quit
Set xlsFil2 = Nothing
End Sub
Private Sub testDataFil1() 'Gennemløb af Fil1 - find SUM-rækker
Dim varenr, celleA, ræk
fil1.Activate
sidsterække = ActiveCell.SpecialCells(xlLastCell).Row
Rem Test om kolonne A begynder med "sum"
For ræk = 1 To sidsterække
celleA = LCase(fil1.Cells(ræk, 1))
If Left(celleA, 3) = "sum" Then
varenr = Mid(celleA, 5)
findVarenrFil2 varenr, fil2ræk, ræk
End If
Next ræk
End Sub
Private Sub findVarenrFil2(varenr, fil2ræk, fil1Ræk) 'Søg varenr i Fil2/Ark1
Dim kolGbeløb, beløb, kolA, kompVnr As Double, kompA As Double
Dim stRæk21
On Error GoTo fejl
kolGbeløb = 0
kompVnr = Val(Left(varenr, 4) & Mid(varenr, 6))
xlsFil2.ActiveWorkbook.Sheets("fane1").Activate
fil2SidsteRække = xlsFil2.ActiveCell.SpecialCells(xlLastCell).Row
stRæk21 = findførsteVnrRække(varenr)
If stRæk21 > 0 Then
For ræk = stRæk21 To fil2SidsteRække
Rem find varenr i Fil2/Ark1
kolA = xlsFil2.Cells(ræk, 1)
kompA = Val(Left(kolA, 4) & Mid(kolA, 6))
If kolA = varenr Then
Rem test om beløb i kolonne G <> kolGbeløb
If xlsFil2.Cells(ræk, 7) <> kolGbeløb Then
kopierTilFil2Ark2 ræk, fil2ræk, 2
kolGbeløb = xlsFil2.Cells(ræk, 7)
End If
Else
If kompA > kompVnr Then 'afbryd hvis større varenr erkendt i Fil2/1
Exit For
End If
End If
Next ræk
kopierTilFil2Ark2 fil1Ræk, fil2ræk, 1
End If
fil1.Activate
Exit Sub
fejl:
Stop
End Sub
Private Function findførsteVnrRække(varenr)
Dim ark21
Set ark21 = xlsFil2.Sheets("fane1")
With ark21.Range("A1:A" + CStr(fil2SidsteRække))
Set c = .Find(varenr, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
findførsteVnrRække = c.Row
Else
findførsteVnrRække = 0
End If
End With
End Function
Private Sub kopierTilFil2Ark2(fraRæk, fil2ræk, fil) 'Kopier rækker til Fil2/Ark2
Dim fraArk, fraRækX, TilArk, tilRæk
On Error GoTo fejl
Set TilArk = xlsFil2.Sheets("fane2")
fraRækX = CStr(fraRæk)
tilRæk = CStr(fil2ræk)
If fil = 2 Then
Set fraArk = xlsFil2.Sheets("fane1")
TilArk.Range("A" & tilRæk) = fraArk.Range("A" & fraRækX)
TilArk.Range("B" & tilRæk) = fraArk.Range("D" & fraRækX)
TilArk.Range("I" & tilRæk) = fraArk.Range("G" & fraRækX)
TilArk.Range("J" & tilRæk) = fraArk.Range("H" & fraRækX)
Else
Set fraArk = ActiveWorkbook.ActiveSheet
TilArk.Range("A" & tilRæk) = fraArk.Range("A" & fraRækX)
TilArk.Range("B" & tilRæk) = fraArk.Range("B" & fraRækX)
TilArk.Range("C" & tilRæk) = fraArk.Range("C" & fraRækX)
TilArk.Range("D" & tilRæk) = fraArk.Range("D" & fraRækX)
TilArk.Range("E" & tilRæk) = fraArk.Range("E" & fraRækX)
TilArk.Range("F" & tilRæk) = fraArk.Range("F" & fraRækX)
TilArk.Range("G" & tilRæk) = fraArk.Range("G" & fraRækX)
End If
If fil = 2 Then
xlsFil2.Sheets("fane1").Activate
End If
fil2ræk = fil2ræk + 1
Exit Sub
fejl:
Stop
Resume Next
End Sub
----------
