Avatar billede graspman Nybegynder
02. juni 2010 - 12:33 Der er 2 kommentarer og
1 løsning

Macro der kopierer data til det første tomme felt i en række

Hej,

Jeg er ved at lave et macro der skal løbe nogle rækker igennem og tjekke om der er dubletter.
Hvis der er dubletter skal den tage data fra kolonne 19+20 og kopierer dem til den aktive række - efterfølgende slette den næste.

eksempel
kundenr        navn        produkt1    pris1  produkt2 pris2   
12              peter        kniv        10
222            palle        hus          50 
222            palle        skorsten    200
56              anders      gaffel        50

Skulle blive til:

kundenr        navn        produkt    pris  produkt  pris
12              peter        kniv        10
222            palle        hus          50    skorsten 200
56              anders      gaffel      50

Jeg har dog problemer med at få kopi funktionen til at virke
samt den palcerer teksten forkeret steder...
Er i tvivl om syntaksen er korrekt?

Håber nogen kan hjælpe


Sub FindDubletter()

Dim iListCount As Integer
Dim iCtr As Integer
Dim ipolCount1 As Integer
Dim ipolCount2 As Integer
Dim CurrRow As Long

       

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = True

' Get count of records to search through.
iListCount = Sheets("ark1").Range("a1:a300").Rows.Count
Sheets("ark1").Range("b2").Select
' Loop until end of records.
Do Until ActiveCell = ""
  ' Loop through records.
  For iCtr = 1 To iListCount
      ' Don't compare against yourself.
      ' To specify a different column, change 1 to the column number.
     
      If ActiveCell.Row <> Sheets("ark1").Cells(iCtr, 2).Row Then
        ' Do comparison of next record.
        If ActiveCell.Value = Sheets("ark1").Cells(iCtr, 2).Value Then
           
     

CurrRow = ActiveCell.Row
'find data i kolonne 19 og kopier det til første tomme celle i rækken
'find data i kolonne 20 og kopier det til første tomme celle i rækken
            Sheets("ark1").Cells(iCtr, 20).Copy Destination:=Cells(CurrRow, Columns.Count).End(xlToLeft).Offset(0, 1)
            Sheets("ark1").Cells(iCtr, 19).Copy Destination:=Cells(CurrRow, Columns.Count).End(xlToLeft).Offset(0, 1)
           
            ' Efter data er kopieret slettes rækken
            Sheets("ark1").Rows(iCtr).Delete xlShiftUp
                     
                ' Sheets("ark1").Cells(iCtr, 1).Delete xlShiftUp
              ' Increment counter to account for deleted row.
            '  ipolCount1 = ipolCount1 + 1
            '  ipolCount2 = ipolCount1 + 1
            '
              iCtr = iCtr + 1
        End If
      End If
  Next iCtr
  ' Go to next record.
  ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Avatar billede excelent Ekspert
03. juni 2010 - 00:08 #1
Prøv på en kopi

Sub tst()
Set sh = Sheets("Ark1")
rk = sh.Cells(300, 1).End(xlUp).Row
For t = 2 To rk
If Application.CountIf(Range("A" & t + 1 & ":A" & rk), Cells(t, 1).Value) Then
x = Range("A" & t + 1 & ":A" & rk).Find(Cells(t, 1), LookIn:=xlValues).Row
Range("S" & x & ":T" & x).Copy Cells(t, Cells(t, 255).End(xlToLeft).Offset(0, 1).Column)
Cells(x, 1).EntireRow.Delete
End If
Next
End Sub
Avatar billede graspman Nybegynder
04. juni 2010 - 14:24 #2
Fik selv løst det - tak for input.
Avatar billede graspman Nybegynder
04. juni 2010 - 14:24 #3
Men brugte en anden løsning.
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview
Kategori
Kurser inden for grundlæggende programmering

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester