Copie par tranche sur nouvelle feuille

B

baptbapt

XLDnaute Occasionnel
Bonjour a tous

Voila j'ai un petit problème lors de la copie de mes données, vous me direz, mais c'est simple une copie, pourquoi il demande sa.

C'est sur, c'est une question de débutant.

Code: 
Sub C_calu()

Const Pi = 3.141592654
Const DegToRad = 0.017453292
Const FeetToNm = 5278.8713
Const EarthRadius = 636000
Const MetresToNm = 0.000622

Dim i As Long
Dim j As Long
Dim wS As Worksheet
Dim wD As Worksheet
Dim Derlig As Long
Dim NbTr As Integer

Do
    NbTr = InputBox("Entrez une valeur de 1 à 256", "Nb Tranches de 2 minutes", 10)
Loop Until (Val(NbTr) > 0) And (Val(NbTr) < 257)

Sheets.Add
ActiveSheet.Name = "Result"

Set wS = Sheets("Result")
Set wD = Sheets("Position convertie")

i = 2
j = 2

Sheets("Position convertie").Select
Derlig = wD.Cells(65536, 10).End(xlUp).Row
For t = 1 To NbTr
    For i = 2 To Derlig
        If Cells(i, 6).Value <> "" _
        And Cells(i, 11).Value = t Then
            For j = 2 To Derlig
             If Cells(j, 10).Value = Cells(i, 10).Value _
             And Cells(i, 6).Value <> Cells(j, 8).Value Then
                lati = (DegToRad / 10000) * Cells(i, 2).Value
                latj = (DegToRad / 10000) * Cells(j, 2).Value
                loni = (DegToRad / 10000) * Cells(i, 3).Value
                lonj = (DegToRad / 10000) * Cells(j, 3).Value
                cj = Cos(latj)
                ci = Cos(lati)
                sj = Sin(latj)
                si = Sin(lati)
                cij = Cos(loni - lonj)
                res = (si * sj) + (ci * cj * cij)
                GDist = MetresToNm * EarthRadius * (Atn(-res / Sqr(-res * res + 1)) + 2 * Atn(1))
                ADiff = Abs(Cells(j, 1).Value - Cells(i, 1).Value) * 100 / FeetToNm
                Adist = Sqr((GDist * GDist) + (ADiff * ADiff))
                wS.Cells(j, 1).Value = Adist
                wS.Cells(j, 4).Value = wD.Cells(j, 11).Value
                If Adist < 5 Then
                    wS.Cells(j, 2).Value = wD.Cells(j, 8).Value
                End If
                If Adist >= 5 And Adist < 10 Then
                    wS.Cells(j, 3).Value = wD.Cells(j, 8).Value
                End If
              End If
            Next j
        End If
    Next i
Next t

End Sub

Voila mon code qui effectue mes calculs, et qui me copie toute mes données sur une meme feuille Result.
Problème, il me fodrait plutot que je copie ses données par tranche, "t" sur des feuilles que je crées automatiquement Result"t" à Result"NbTr"

Mais voila, j'ai eu mes données pour la tranche1, mais pas pour les autres

De plus, j'ai un énorme problème de vitesse, 20 minutes pour réaliser cette macro, bon j'avoue elle effectue 65000000 de fois la macro, c'est long.

SI quelqu'un a une méthode pour crtéer des feuilles et copier les valeurs dessus par tranche, en automatique

Je suis preneur

Merci
 
Trier par date Trier par votes
B

baptbapt

XLDnaute Occasionnel
Re : Copie par tranche sur nouvelle feuille

Ou sinon, plus simple

Qui me copie mes données suivant mes tranches et les tri suivant la colonne B sur des nouvelles feuilles de Result"t" à Result"NtBr"
après que la feuill Result ai été rempli

Je supprime ensuite la feuille Result

Par contre, je ne sait pas comment faire
 
Vote positif 0 Vote négatif
B

baptbapt

XLDnaute Occasionnel
Re : Copie par tranche sur nouvelle feuille

Code: 
Sub copie_tranche()
Dim wE As Worksheet
Dim wT As Worksheet
Dim J As Long
Dim Derligc As Long
Set wT = Sheets("Result")

wT.Activate
NbTr = 2

For t = 1 To NbTr
Set wE = Sheets.Add(after:=Sheets(Sheets.Count))
wE.Name = "Result" & t
J = 1
Derligc = wT.Cells(65536, 4).End(xlUp).Row
    For i = 2 To Derligc
        If wT.Cells(i, 4) = t Then
            wE.Rows(J).Value = wT.Rows(i).Value
            J = J + 1
        End If
    Next i
Set wE = Nothing
Next t

End Sub

J'ai réussi a faire le copie sur des feuilles suppléméntaire

Par contre comment trier mes données selon colonne B et suppimer, tout les doublon dans cette meme colonne, soit effacer valeur, ou ligne complète

Code: 
1,704909946	AFR1271		1
1,326047363	LIL470		1
5,152616764	DLH4AF	DLH4AF	1
1,51547682	LOT261		1
0,189434707	OLT668		1
0,757739486	LGL9252		1
2,083779219	NLY8331		1
1,136607031	PIA523		1
1,420761954	MAH617		1
1,13660726	BRT2BJ		1
1,326041738	RAE465		1
2,083778793	BAW770G		1
1,894344602	BAW843		1
2,083778793	DAT61N		1
0,000232676	AFR1271		1
0,378891131	LIL470		1
6,838583171	DLH4AF	DLH4AF	1
0,189444473	LOT261		1

merci
 
Vote positif 0 Vote négatif
porcinet82

porcinet82

XLDnaute Barbatruc
Re : Copie par tranche sur nouvelle feuille

Salut baptbapt,

Une macro qui te permet de trier par rapport a la colonne B puis de supprimer les doublons toujours de la meme colonne

PHP: 
Sub Macro2()
Dim i&
Columns("B:B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For i = Range("B65536").End(xlUp).Row To 2 Step -1
    If Cells(i - 1, 2).Value = Cells(i, 2).Value Then
        Rows(i).Delete
    End If
Next i
End Sub

@+
 
Vote positif 0 Vote négatif
B

baptbapt

XLDnaute Occasionnel
Re : Copie par tranche sur nouvelle feuille

Salut Porcinet

Code: 
AFR1271	ACA1895		
	ACA844		
	AFR1271		
	AFR1431		
	BAW770G	GWI284	UAL740
	BAW843	KLM1619	UAL740
	BRT2BJ		
	DAT61N		
	DLH4323	DLH4AF	UAL740
	DLH4AF		
	EIN650		
	GWI284		
	KLM1619	KLM1619	UAL740
	KLM458		
OLT668	LGL9252		
AFR1271	LIL470		
	LOT261	GWI284	UAL740
	MAH617	KLM1619	UAL740
	NLY8331		
	OLT668		
	PIA523		
	RAE465		
DAT61N	SCW511		
	UAL740

maintanant, voila mes résultat, sur ma feuille tranche1

Mais comment mettre les éléments de la colonne2 à la suite de la colonne1
et ceux de la 3 à la suite de la 4

C'est plutot sa que j'orai du faire avant de supprimer les doublons
mais on peut chanegr le code, et dire d'effacer la valeur, plutot que le ligne correspondante
 
Vote positif 0 Vote négatif
porcinet82

porcinet82

XLDnaute Barbatruc
Re : Copie par tranche sur nouvelle feuille

re,

Alors je ne comprends plus, tu parles de données a trier selmon la colonne B alors que tu te retrouve avec le meme genre de données sur 4 colonnes ????? Soit un peu plus clair sinon on va jamais y arriver.

Pour supprimer une cellule a la place d'une ligne, il faut utiliser (dans mon code) Cells(i, 2).Delete Shift:=xlUp

Pour le reste, j'ai pas le temps de regarder maintenant,

@+
 
Vote positif 0 Vote négatif
B

baptbapt

XLDnaute Occasionnel
Re : Copie par tranche sur nouvelle feuille

C'est bon, pour trier sur toute mes colonnes, j'ai recopier le code, c'est barbare, mais sa fonctionne

Code: 
    Dim p&
    Columns("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    For p = Range("A65536").End(xlUp).Row To 2 Step -1
        If Cells(p - 1, 1).Value = Cells(p, 1).Value Then
            Cells(p, 1).Delete
        End If
    Next p
Sa ne gène pas si on ne met pas le "Shift:=xlUp"
 
Vote positif 0 Vote négatif
B

baptbapt

XLDnaute Occasionnel
Re : Copie par tranche sur nouvelle feuille

Dernier point a solutionner et j'en orai terminé avec se programme

Code: 
ACA1895	ACA1895	BAG42V
ACA844	BAW843	GWI284
AFL127	DAT41G	
AFR1271	DLH2UM	
AFR1431	HLX3126	
BAG42V	ISS3424	
BAG72X	KLM1839	
BAW770G	KLM1953	
GSM163
GWI284

Voila une page de résultat

en colonne A et B, mes avions étant proche de 5 miles ou moins, ou compris entre 5 et 10

en colonne C, les avions en conflit, "qui vont se rentré dedans quoi"
Comment faire pour supprimer des colonnes A et B, les avions de la colonne C

Merci
 
Vote positif 0 Vote négatif
porcinet82

porcinet82

XLDnaute Barbatruc
Re : Copie par tranche sur nouvelle feuille

re,

Tiens voici une macro qui devrait faire ce que tu veux :
PHP: 
Sub Test_v4()
Dim i&, j&, cel As Range
For Each cel In Range("C1:C" & Range("C65536").End(xlUp).Row)
    For j = 1 To 2
        For i = 1 To Range("A65536").End(xlUp).Row
            A = Cells(i, j).Value
            If cel = Cells(i, j).Value Then
                Cells(i, j).Delete Shift:=xlUp
            End If
        Next i
    Next j
Next cel
End Sub

@+
 
Vote positif 0 Vote négatif

Discussions similaires

PatLac
  • Question
Envoyer SMS par feuille excel via Macro - CODE EXISTANT à modifier
2
Réponses
20
Affichages
15 K
Staple1600
Staple1600
M
  • Question
Imprimer une feuille par dossier sur une autre feuille .
Réponses
3
Affichages
848
matmat36
M
C
  • Question
Macro copie sous condition et sur plusieur feuille
Réponses
2
Affichages
11 K
creolia
C
B
  • Question
Boucle multiple avec condition multiple en VBA
Réponses
2
Affichages
3 K
baptbapt
B
B
  • Question
Copie multiple au sein d'une boucle
Réponses
12
Affichages
1 K
Bebere
B
B
  • Question
Copie dernière valeur de chaque type sur feuille suivante
Réponses
3
Affichages
1 K
Creepy
C

Membres actuellement en ligne

9 membres et 79 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 582
Messages
2 089 922
Membres
104 307
dernier inscrit
Diet