Astuces Excel
  1. Astuces Excel
  3. Excel VBA: Transpose différentes parties d'une string
Intereting Posts
Trouver et replace du text dans excel Modification d'un model basé sur excel dans VB.NET Excel – Index / Match returnne 0 pour les blancs, souhaitez sauter des blancs Compter les cellules correspondantes dans une gamme dans Excel Le moyen le plus simple d'avoir un rapport de fonction 2 sorties Tables de pivotement Excel: search des valeurs maximales de la sous-rangée Copiez la ligne entière d'une feuille de calcul vers une autre basée sur la colonne A de la feuille de calcul différente Est-il possible de sortinger (coloré) les cellules après leur mise en forme conditionnelle? CSV est trop grand pour être traité via AJAX Comment exporter directement une collection de DTO vers CSV, Excel ou PDF? En comptant le nombre de fois, une valeur est répétée deux fois de suite Pouvez-vous dire à Excel de ne pas recalculer une cellule dont le contenu est basé sur un composant COM? VBA Type d'erreur 13: incompatibilité ADO avec KDB + / qodbc.dll dans VBA Excel: macro de variation en pourcentage excluant les lignes non numériques

Excel VBA: Transpose différentes parties d'une string

J'ai des valeurs qui sont horizontalement dans les cellules à côté de l'autre. Dans chaque cellule, j'achète une certaine sous-string de la cellule et je veux transposer chaque partie verticalement dans certaines colonnes.

Exemple: 

ColA ColB ColC First.Second<Third> Fourth.Fifth<Sixth> Seventh.Eighth<Ninth>

Devrait apparaître sur une nouvelle feuille de calcul (ws2): 

  ColA ColB ColC First Second Third Fourth Fifth Sixth Seventh Eighth Ninth

J'ai essayé de boucler des lignes et des colonnes, mais cela a sauté au hasard 

 For i = 2 to lastRow lastCol = ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column For j = 2 to lastCol cellVal = ws.Cells(i, j).Value firstVal = Split(cellVal, ".") secondVal = 'extract second val thirdVal = 'extract third val ws2.Cells(i,1).Value = firstVal ws2.Cells(i,2).Value = secondVal ws3.Cells(i,4).Value = thirdVal

EDIT: Mise à jour presque code de fonctionnement ci-dessous: 

 Sub transPose() Dim used As Range Set used = Sheet1.UsedRange 'make better constraint if necessary Dim cell As Range Dim arr(0 To 3) As Ssortingng Dim str As Ssortingng Dim pointStr As Variant, arrowSplit As Variant Dim rowCount As Long rowCount = 0 For Each cell In used 'This goes across rows and then down columns str = Trim(cell.Value2) If str <> "" Then 'Use better qualification if necessary spaceStr = Split(str, " ") arr(0) = spaceStr(0) arr(1) = spaceStr(1) arrowSplit = Split(spaceStr(1), "<") arr(2) = LCase(Mid(str, Application.Find("<", str) + 1, 1)) & LCase(arrowSplit(0)) openEmail = InStr(str, "<") closeEmail = InStr(str, ">") arr(3) = Mid(str, openEmail + 1, closeEmail - openEmail - 1) rowCount = rowCount + 1 Sheet2.Cells(1 + rowCount, 1).Resize(1, 4).Value = arr End If Next cell End Sub

EDIT2: datatables ressemblent en fait 

  ColA ColB etc... John Smith<[email protected]> Jane Doe<[email protected]>

Et devrait ressembler à: 

 ColA ColB ColC ColD John Smith jsmith [email protected] Jane Doe jdoe [email protected]

Essaye ça: 

 Sub transPose() Dim used As Range Set used = Sheet1.UsedRange 'make better constraint if necessary Dim cell As Range Dim arr(0 To 2) As Ssortingng Dim str As Ssortingng Dim pointStr As Variant, arrowSplit As Variant Dim rowCount As Long rowCount = 0 For Each cell In used 'This goes across rows and then down columns str = cell.Value2 If str <> "" Then 'Use better qualification if necessary pointStr = Split(str, ".") arr(0) = pointStr(0) arrowSplit = Split(pointStr(1), "<") arr(1) = arrowSplit(0) arr(2) = Split(arrowSplit(1), ">")(0) rowCount = rowCount + 1 Sheet2.Cells(1 + rowCount, 1).Resize(1, 3).Value = arr End If Next cell End Sub

Pour chaque ligne d'input, vous disposerez de 3 lignes de sortie, ce qui signifie que vous augmentez la ligne de sortie par 3 pour chaque ligne d'input. En outre, la fonction Cells prend des parameters (ligne, col).

Les mathématiques deviennent maladroites si vous êtes itérant i et j de la ligne de départ / col à la dernière ligne / col, alors je suggère plutôt d'itérer sur le nombre de lignes / cols et en utilisant un sharepoint départ pour la reference, soit une cellule stockée comme un object Range ou la ligne start / col. 

 For i = 0 to ws.Rows.Count For j = 0 to ws.Columns.Count cellVal = ws.Cells(i + startRow, j + startCol).Value firstVal = Split(cellVal, ".") secondVal = 'extract second val thirdVal = 'extract third val ws2.Cells((i*3) + startRow, j + startCol).Value = firstVal ws2.Cells((i*3) + 1 + startRow, j + startCol).Value = secondVal ws3.Cells((i*3) + 2 + startRow, j + startCol).Value = thirdVal

Etc…

En fait, si je faisais cela, je ferais probablement des parameters inputRange et outputRange de la fonction, puis je vais simplement l'itérer à travers ceux-ci. Cela simplifiera à la fois l'itération (pas besoin de start-up désordonné ou startCol) et l'indexing. Si vous searchz ce type de solution, déposez un commentaire et je peux l'append.

édité après la question éditée par OP

vous pourriez essayer ceci: 

 Sub main2() Dim cell As Range, row As Range Dim arr As Variant Dim finalValues(1 To 4) As Ssortingng Dim iRow As Long Dim ws As Worksheet, ws2 As Worksheet Set ws = Worksheets("originalData") '<--| change "originalData" to your actual sheet name with starting data Set ws2 = Worksheets("results") '<--| change "results" to your actual sheet name with starting data For Each row In ws.UsedRange.Rows For Each cell In row.SpecialCells(xlCellTypeConstants) arr = Split(Replace(Replace(cell.Value, "<", " "), ">", ""), " ") finalValues(1) = arr(0): finalValues(2) = arr(1): finalValues(3) = Left(arr(0), 1) & arr(1): finalValues(4) = arr(2) iRow = iRow + 1 ws2.Cells(iRow, 1).Resize(, UBound(finalValues)).Value = finalValues Next Next End Sub