Hjælp til at udvide makro!
Hej!Hver måned får jeg en fil med 2 kolonner: i kolonne A er kundens nummer og navn, mens i kolonne B er antal kilo han har købt på en måned.
eks.
A B
145623 Jens Jensen 320
Jeg har en anden fil som jeg kalder salgsoversigt hvor jeg har kolonne A med kundens nr., kolonne B med kundens navn og kolonne c - z er antal kilo som kundens har købt fra januar 2004 frem til nu.
A B C(jan.04) d(feb.04)
123456 Nils Jensen 245 300 osv.
Jeg har fået her på eksperten nedenstående makro som overfører det antal kilo kunden har købt i denne måned til min salgsoversigt fil dvs programmet finder den samme kunde og i kolonne AA i salgsoversigt filen skriver det antal kilo kunden har købt.
Problemet er at jeg nu har 15 salgsoversigt filer dvs. at hvis kundensnr starter med 15 så skal der overføres til filen salgsoversigt15.xls, hvis kundensnr starter med 16 så skal der overføres til filen salgsoversigt16.xls. Er der nogen der kan hjælpe?
Private Sub CommandButton1_Click()
'Public Sub Exp663895()
Const sSalesFile As String = "d:\salgsoversigt.xls" 'Skal ændres
Const sSalesSheetName As String = "Ark1" 'Skal ændres
' sCellToWriteIn - Skal ændres hver måned, så der skrives i den
' rigtige kolonne det er nødvendigt fordi kolonnen ikke kan findes
' automatisk, når ikke der er tal i alle celler.
Const sCellToWriteIn As String = "Z1"
Dim wkbNew As Excel.Workbook
Dim wkbSales As Excel.Workbook
Dim wksImport As Excel.Worksheet
Dim wksView As Excel.Worksheet
Dim lRowFrom As Long
Dim lRowTo As Long
Dim bFound As Boolean
'On Error GoTo CleanUp
Set wkbNew = ActiveWorkbook
Set wksImport = wkbNew.ActiveSheet
Set wkbSales = Application.Workbooks.Open(Filename:=sSalesFile)
Set wksView = wkbSales.Worksheets(sSalesSheetName)
' 2-tallet her bestemmer hvilken række det første kundenr findes i (Update-filen)
For lRowFrom = 2 To wksImport.UsedRange.Rows.Count
bFound = False
' 3-tallet her bestemmer hvilken række det første kundenr findes i (Salgsview-filen)
For lRowTo = 3 To wksView.UsedRange.Rows.Count
If Val(wksImport.Cells(lRowFrom, 1).Value) = _
wksView.Cells(lRowTo, 1).Value Then
wksView.Cells(lRowTo, wksView.Range(sCellToWriteIn).Column).Value = _
wksImport.Cells(lRowFrom, 2).Value
bFound = True
Exit For
End If
Next lRowTo
If Not bFound Then
'Cellen bliver rød, hvis ikke den er overført til opsummeringsarket
wksImport.Cells(lRowFrom, 1).Interior.ColorIndex = 3
End If
Next lRowFrom
CleanUp:
Set wksImport = Nothing
Set wksView = Nothing
Set wkbNew = Nothing
Set wkbSales = Nothing
'End Sub
End Sub
