Création d'un Excel supplémentaire en utilisant la macro

Question

Je suis en train d'avoir un Excel avec une colonne qui a des informations concernant l'offre. Chaque cellule aura une valeur comme

Colonne: Nokia ([Mode1.Number], VIEUX)

Colonne: Motorola ([Mode1.Number], VIEUX)

Colonne: Motorola ([Mode2. numéro], NOUVEAU)

Colonne: Motorola ([Mode3.Number], VIEUX)

Colonne: Samsung ([Mode2.Number], NOUVEAU)

Je dois créer 2 exceller sur ce . On devrait avoir toutes les informations de l'OLD et le second Excel devrait avoir toutes les informations de NEW.

Ma sortie Excel doit contenir

Première Excel

Nokia ([Model1.Number])

Motorola ([Mode1.Number])

Motorola ([Mode3.Number ])

Deuxième Excel

Motorola ([Mode2.Nu] mbre])

Samsung ([Mode2.Number])

bien vouloir me aider .. Merci à l'avance ..

Answer 1

Sélectionnez les cellules contenant les données que vous souhaitez copier puis exécuter ce code

sub copystuff 
dim r as range 
dim tn as range 
im to as range 
dim wsNewTarget as worksheet 
dim wsOldTarget as worksheet 
dim wsSource as worksheet 
set wsSource = activesheet 
set wsNewtarget = activeworkbook.worksheets.add 
set wsoldtarget = activeworkbook.worksheets.add 
set tn = wsnewtarget.range("a1") 
set to =wsoldtarget.range("a1") 
for each r in wssource.selection 
    if imstr(r,"NEW")>0 then 
      tn=r 
      set tn = tn.offset(1,0) 
    else 
     to=r 
      set to = to.offset(1,0) 

    end if 
next r 
end sub 

Answer 2

Sub SplitOldNew() 
Dim InRange As Range, OldRange As Range, NewRange As Range 
Dim Idx As Integer 

    Set InRange = Selection    ' select all cells to be split 
    Set OldRange = Worksheets("OLD").[A1] ' choose appropriate target entry points 
    Set NewRange = Worksheets("NEW").[A1] ' ... 
    Idx = 1        ' loop counter 

    Do While InRange(Idx, 1) <> "" 
     If InStr(1, InRange(Idx, 1), "OLD") <> 0 Then 
      DBInsert OldRange, InRange(Idx, 1) 
     Else 
      DBInsert NewRange, InRange(Idx, 1) 
     End If 
     Idx = Idx + 1 
    Loop 
End Sub 

Sub DBInsert(intoRange As Range, Arg As String) 
Dim Idx As Integer 

    Idx = 1        ' loop counter 
    Do While intoRange(Idx, 1) <> ""  ' find first blank row 
     Idx = Idx + 1 
    Loop 

    intoRange(Idx, 1) = Arg    ' write out 
End Sub