09. maj 2009 - 01:02Der er
1 kommentar og 1 løsning
Kopiere værdier fra valgte celler i ark 1 til 12 ud fra værdi i celle på værdi ark
Hejsa eksperter!
Nu har jeg læst og klippet og klistret i 5 uger, og det vil bare ikke lykkes.
Det jeg gerne vil have hjælp til er en makro. Jeg bruger Excel 2007 på en maskine med vista.
Regnearket er på 36 ark Ark 1 til 12 er navngivet "Jan, Feb, Mar" osv. "kun 3 bogstaver" Ark 36 er navngivet "Værdi"
Ark 36: værdi Kolonne B række 2 står dags dato Kolonne B række 4 står datoen 1-1-09 Kolonne B række 5 til 369 er formelbaseret således at datoerne kun fremkommer når dags dato oprunder.
Ark 1 til 12: Jan, Feb, Mar osv. Kolonne B række 4 dato for første dag i md., efterfølgende datoer for md. står nedefter i kolonne B. Slut rækken variere da md. ikke er lige lange, Jan er række 34, Feb 31, Mar 34, Apr 33 osv.
Makroen skal tage værdi/dato "søgekriteria" i kolonne B på ark 36 "værdi arket" søge efter tilsvarende værdi/dato i kolonne B på ark 1 til 12, når den finder en match skal den kopiere værdierne fra cellerne "G, I, K, N, Q, T, W, Z" i samme række som match er fundet "også tomme celler" og paste til kolonne C, D, E i samme række på "værdi arket" som søgekriteria er taget fra altså G til C, I til D, K til E osv. det skal kun være værdierne og ikke formlerne der skal kopieres, format og celle brede skal være det samme. Næste celle i kolonne B på "værdi arket" køre søgning og kopiering igen
Når der ikke er flere datoer i kolonne B på "værdi arket" skal makroen stoppe.
Makroen skal starte forfra hvergang den køres.
hvis jeg ikke har gjort mig forstålig nok så spørg.
Set I = Sheets Dim LDate As Variant Dim LColumn As Integer Dim LFound As Boolean Dim n Dim j
n = 4
Application.ScreenUpdating = False
For d = 1 To 12 'Arbejder sig igennem Ark 1 til 12
j = 4 r = 4
Sheets(d).Activate 'Aktivere Arket
While Cells(r, 2) > 0 'Finder sidste celle i kolonne B med værdi r = r + 1 Wend Cells(r - 1, 2).Select Range(ActiveCell, ActiveCell.End(xlUp)).Select 'Markere celler i kolonne B med værdi
For Each Cell In Selection 'For hver celle i markering
LDate = Sheets("Værdi").Range("B" & n).Value 'Henter dato værdi der skal søges efter
Cells(j, "G").Select
Sheets(d).Select
LColumn = 2 'Vælger kolonne B LFound = False
While LFound = False
If Len(Cells(j, LColumn)) = 0 Then 'Når ingen matgh er fundet stoppes makroen Cells(j, "G").Select Exit Sub
ElseIf Cells(j, LColumn) = LDate Then 'Fundet match i række Sheets(d).Select 'Vælger værdier til kopiering fra "Måneds" Ark Range("G" & j & ":AB" & j).Copy Sheets("Værdi").Select 'Sætter ind på "Værdi" Ark Cells(n, LColumn + 1).Select Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False LFound = True Else 'Fortsæt Søgning LColumn = LColumn + 1 End If
Jeg kan godt se at der er nogle underlige tegn imellem, så jeg prøver igen
Sub CopyDataToVaerdi()
Set I = Sheets Dim LDate As Variant Dim LColumn As Integer Dim LFound As Boolean Dim n Dim j
n = 4
Application.ScreenUpdating = False
For d = 1 To 12 'Arbejder sig igennem Ark 1 til 12
j = 4 r = 4
Sheets(d).Activate 'Aktivere Arket
While Cells(r, 2) > 0 'Finder sidste celle i kolonne B med værdi r = r + 1 Wend Cells(r - 1, 2).Select Range(ActiveCell, ActiveCell.End(xlUp)).Select 'Markere celler i kolonne B med værdi
For Each Cell In Selection 'For hver celle i markering
LDate = Sheets("Værdi").Range("B" & n).Value 'Henter dato værdi der skal søges efter
Cells(j, "G").Select
Sheets(d).Select
LColumn = 2 'Vælger kolonne B LFound = False
While LFound = False
If Len(Cells(j, LColumn)) = 0 Then 'Når ingen matgh er fundet stoppes makroen Cells(j, "G").Select Exit Sub
ElseIf Cells(j, LColumn) = LDate Then 'Fundet match i række Sheets(d).Select 'Vælger værdier til kopiering fra "Måneds" Ark Range("G" & j & ":AB" & j).Copy Sheets("Værdi").Select 'Sætter ind på "Værdi" Ark Cells(n, LColumn + 1).Select Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False LFound = True Else 'Fortsæt Søgning LColumn = LColumn + 1 End If
Wend
n = n + 1 j = j + 1 Next Next d
Exit Sub
Application.ScreenUpdating = True
End Sub
Det ser bedre ud
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
