VB makro til at flette to datasæter
Hej alle sammen,Sidste uge spurgte jeg forum om meget kompliceret fletning og fordi der var ingen som kun hjælpe og jeg er lige tabt på området, så besluttede jeg at flette bare to datasæter. Så får jeg en mulighed for at manipulere data ved brug af filtrering.
Min opgave: der er to projektmapper, hvor en af dem bruges som hoved-fil med det oprindelige datasæt og den anden af dem svarer til opdateringer på det oprindelige data. Hovedfilen er på størrelsen i A1:L, hvor den første række står for navner. Opdateringsfilens data ligger i området: A1:Q, hvor den første række igen svarer til kolonnens navner. I kolonnen D af opdateringsfilen står der varer nummer som findes i kolonnen G af hovedfilen (i ubestemt rækkefølge).
Jeg vil gerne få en makro som finder en match mellem de to kolonnen D i opdateringsfilen og kolonnen G i hovedfilen og kopierer tilsvarende kolonner fra opdateringsfilen til compliance2 file (oprindelige file). Dette har jeg afprøvet at udføre via arrayer der data størrelsen er på ca. 30.000 rækker. Min makro køres men som resultat får jeg kun første tre rækker fra det første array.
Jeg håber der er nogen der kan hjælpe med at kigge på min kode.
Public Sub FletteToDataMedVarerID()
Dim Updatedata As Variant, Compliance2data As Variant, vDato As Variant
Dim vCompliance2(), vUpdate(), vResult()
Dim rVareNrCom2 As Range, rVareNrUpdate As Range
Dim bAbort As Boolean, dFound As Double
Dim lResultCol As Long, lResultRows As Long
Dim lLast As Long, i As Long, j As Long
Dim lmax As Long, lCol As Long, lVcount As Long
Dim lHits As Long, lCount2 As Long, LCount3 As Long
ThisWorkbook.Worksheets("update").Activate
If Len(Range("A3")) > 0 Then
Set rVareNrUpdate = Range(Range("A2"), Range("A2").End(xlDown))
Set rVareNrUpdate = Range(rVareNrUpdate, rVareNrUpdate.Offset(0, 16))
Else
Set rVareNrUpdate = Range(Range("A2"), Range("A2").Offset(0, 16))
End If
vUpdate() = rVareNrUpdate.Value
ThisWorkbook.Worksheets("Compliance2").Activate
If Len(Range("A3")) > 0 Then
Set rVareNrCom2 = Range(Range("A2"), Range("A2").End(xlDown))
Set rVareNrCom2 = Range(rVareNrCom2, rVareNrCom2.Offset(0, 11))
Else
Set rVareNrCom2 = Range(Range("A2"), Range("A2").Offset(0, 11))
End If
With rVareNrCom2
vResult() = .Value
lResultCol = .Columns.Count
lResultRows = .Rows.Count
End With
Set rVareNrCom2 = Nothing
Dim lCount As Long
Dim colVareNrCom2 As New Collection
On Error Resume Next
For lCount = 1 To UBound(vResult)
colVareNrCom2.Add vResult(lCount, 1), vResult(lCount, 1) 'unikke værdier
Next
On Error GoTo ErrorHandle
With colVareNrCom2
For lCount = 1 To .Count
lLast = 0
dFound = WorksheetFunction.CountIf(rVareNrUpdate.Columns(4), .Item(lCount))
If dFound > 0 Then
lCol = dFound * 16
ReDim vCompliance2(1 To 1, 1 To lCol)
If lCol > lmax Then lmax = lCol
For lVcount = 1 To UBound(vUpdate)
If vUpdate(lVcount, 4) = .Item(lCount) Then
lHits = lHits + 1
vCompliance2(1, lLast + 1) = vUpdate(lVcount, 1)
vCompliance2(1, lLast + 2) = vUpdate(lVcount, 2)
vCompliance2(1, lLast + 3) = vUpdate(lVcount, 3)
vCompliance2(1, lLast + 4) = vUpdate(lVcount, 4)
vCompliance2(1, lLast + 5) = vUpdate(lVcount, 5)
vCompliance2(1, lLast + 6) = vUpdate(lVcount, 6)
vCompliance2(1, lLast + 7) = vUpdate(lVcount, 7)
vCompliance2(1, lLast + 8) = vUpdate(lVcount, 8)
vCompliance2(1, lLast + 9) = vUpdate(lVcount, 9)
vCompliance2(1, lLast + 10) = vUpdate(lVcount, 10)
vCompliance2(1, lLast + 11) = vUpdate(lVcount, 11)
vCompliance2(1, lLast + 12) = vUpdate(lVcount, 12)
vCompliance2(1, lLast + 13) = vUpdate(lVcount, 13)
vCompliance2(1, lLast + 14) = vUpdate(lVcount, 14)
vCompliance2(1, lLast + 15) = vUpdate(lVcount, 15)
vCompliance2(1, lLast + 16) = vUpdate(lVcount, 16)
lLast = lHits * 16
End If
Next
End If
If dFound > 0 Then
If lResultCol < 12 + lmax Then
lResultCol = 12 + lmax
ReDim Preserve vResult(1 To lResultRows, 1 To lResultCol)
End If
For lCount2 = 1 To UBound(vResult)
If vResult(lCount2, 1) = .Item(lCount) Then
For LCount3 = 1 To lCol
vResult(lCount2, 12 + LCount3) = vUpdate(1, LCount3)
Next
End If
Next
End If
lHits = 0
Next
End With
Worksheets.Add.Name = "Com2Opdateret"
Set rVareNrUpdate = Range(Range("A2"), Range("A2").Offset(lResultCol))
Set rVareNrUpdate = rVareNrUpdate.Resize(lResultRows, lResultCol)
rVareNrUpdate.Value = vResult()
Set rVareNrCom2 = Range(Range("A1"), Range("A1").Offset(0, lResultCol - 1))
With rVareNrCom2
.Interior.Color = 12688476
.Font.Bold = True
.Font.ColorIndex = 2
.Item(1).Value = "bubobuboID"
.Item(2).Value = "SellerPartyTaxID"
.Item(3).Value = "SellerPartyName"
.Item(4).Value = "ContractID"
.Item(5).Value = "ContractType"
.Item(6).Value = "ItemGroup"
.Item(7).Value = "ItemID"
.Item(8).Value = "ItemDesc"
.Item(9).Value = "Price"
.Item(10).Value = "unit"
.Item(11).Value = "FromDate"
.Item(12).Value = "ToDate"
For lCount = 13 To lResultCol
lHits = lCount Mod 16
Select Case lHits
Case 1
.Item(lCount).Value = "Aftalenummer"
Case 2
.Item(lCount).Value = "Actionkode"
Case 3
.Item(lCount).Value = "Nyt varenummer"
Case 4
.Item(lCount).Value = "Ny varetekst"
Case 5
.Item(lCount).Value = "Gammel varetekst"
Case 6
.Item(lCount).Value = "Ny SKI-pris"
Case 7
.Item(lCount).Value = "Gammel SKI-pris"
Case 8
.Item(lCount).Value = "Ny bestillingsenhed"
Case 9
.Item(lCount).Value = "Gammel bestillingsenhed"
Case 10
.Item(lCount).Value = "Ny salgbart kvantum"
Case 11
.Item(lCount).Value = "Gammel salgbart kvantum"
Case 12
.Item(lCount).Value = "Ny brugbart indhold"
Case 13
.Item(lCount).Value = "Gammel brugbart indhold"
Case 14
.Item(lCount).Value = "Enhedspris"
Case 15
.Item(lCount).Value = "Prisstigning/-fald %"
Case 16
.Item(lCount).Value = "Ændringstype"
End Select
Next
End With
BeforeExit:
Set rVareNrCom2 = Nothing
Set rVareNrUpdate = Nothing
Set colVareNrCom2 = Nothing
Erase vResult
Erase vCompliance2
Erase vUpdate
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Flet"
bAbort = True
End Sub
