Exporter des données de plusieurs onglets et les transposer
Bonjour à tous,
Je rencontre quelques difficultées pour terminer mon fichier Excel.
Résumé :
J'obtiens une feuille avec plusieurs onglets (leur nombre peut varier). Ces onglets renferment des données que je dois exporter sur un autre classeur Excel.
J'importe déjà les dates correspondant aux données dans mon autre classeur, , jusqu'ici aucun problème.
C'est lorsque j'importe mes données et que je les transposent que j'obtiens un problème.
En effet, dans mon test seulement 2 lignes sur 3 sont recopiées. J'utilise un compteur d'onglet pour activer et recopier mes valeurs un onglet après l'autre.
voici mon code :
Sub exporte()
Dim Wbk1 As Workbook, Wbk2 As Workbook
Set Wbk1 = ThisWorkbook
Dim j As Integer
Dim z As Integer
Dim n As Integer
Dim m As Integer
Dim dligne As Integer
j = 2
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name = "Traitement" Then
Else
Windows("test.xls").Activate
ActiveWorkbook.Worksheets(i).Activate
Range("A1").Copy
Windows("Suivi_rebus_1546.xls").Activate
Sheets("Données").Select
Range("A" & j).Select
Selection.PasteSpecial
j = j + 1
End If
Next
m = 2
For n = Sheets.Count To 1 Step -1
If Sheets(n).Name = "Traitement" Then
Else
Windows("test.xls").Activate
ActiveWorkbook.Worksheets(n).Activate
dligne = Range("A" & Rows.Count).End(xlUp).Row
Range("J1 : J" & dligne).Copy
Windows("Suivi_rebus_1546.xls").Activate
Sheets("Données").Select
Range("B" & m).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
m = m + 1
End If
Next
End Sub
Pouvez-vous me dire d'où vient l'erreur ?
En espérant avoir été assez clair.
Merci d'avance
bonjour,
essaie ceci
Sub exporte()
Dim Wbk1 As Workbook, Wbk2 As Workbook
Set Wbk1 = ThisWorkbook
Set Wbk2 = Workbooks("Suivi_rebus_1546.xls")
Dim j As Integer
Dim z As Integer
Dim n As Integer
Dim m As Integer
Dim dligne As Integer
j = 2
Application.DisplayAlerts = False
For Each ws In Wbk1.Worksheets
If ws.Name <> "Traitement" Then
dligne = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1").Copy
Wbk2.Sheets("Données").Range("A" & j).PasteSpecial Paste:=xlValues
ws.Range("J1 : J" & dligne).Copy
Wbk2.Sheets("Données").Range("B" & j).PasteSpecial Paste:=xlPasteAll, Transpose:=True
j = j + 1
End If
Next
Application.DisplayAlerts = true
End Sub