Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen

Gleiche Werte nach rechts kopieren | Herbers Excel-Forum


Betrifft: Gleiche Werte nach rechts kopieren von: Erwin_Geer
Geschrieben am: 18.11.2009 09:10:21

Guten Morgen,

ich habe Tabellen, die z. B. 5 Spalten breit und manchmal mehrere 1.000 Zeilen lang ist.

Dabei kann es vorkommen, dass z. B. in Spalte A manchmal gleiche (eindeutige) Werte (Aktenzeichen oder Namen) untereinander stehen können, aber in den Spalten B, C, D, E andere Werte dazu enthalten sind.

Ich möchte nun per VBA (nicht Pivot Funktion), dass in Spalte A der Wert nur noch ein einziges mal steht und alle Werte zu einem Aktenzeichen o. Namen nach rechts in die erste vorkommende Zeile kopiert werden.

Zum besseren Verständnis habe ich eine Datei hochgeladen, die den IST Zustand und das SOLL darstellt.
https://www.herber.de/bbs/user/66000.xls

Wer kann mir bitte helfen?

- Erwin -

  

Betrifft: ..warum nicht Pivot?... von: robert
Geschrieben am: 18.11.2009 09:25:07

hi,

stelldir vor , du hast 12 Huber

wie sieht dann deine tabelle aus?

das ist doch ein klassiker für pivot

gruß
robert


  

Betrifft: AW: ..warum nicht Pivot?... von: Erwin_Geer
Geschrieben am: 18.11.2009 09:35:59

Hallo Robert,
zum einen ist das immer eindeutig in einer Zelle (ist vom HOST System so; i. d. R. Zahlenkombination),
zum anderen kenne ich mich mit Pivot fast nicht aus,
zum dritten habe ich Nachfolgemakros, die schon laufend benutzt werden und mit Pivot nicht zurecht kommen.
Mir wäre deshalb schon an einer VBA - Lösung gelegen.
Grüße
Erwin


  

Betrifft: Tabelle mit VBA umstellen von: Erich G.
Geschrieben am: 18.11.2009 12:10:17

Hi Erwin,
probier mal

Option Explicit

Sub Umorg()
   Dim strS As String, cI As Long, lngZ As Long, cA As Long
   Dim zz As Long, cc As Long, varM
   
   strS = InputBox("Spaltenbuchstabe:", "Umorg")
   cI = Range(strS & 1).Column
   lngZ = Cells(Rows.Count, cI).End(xlUp).Row
   cA = Cells(4, Columns.Count).End(xlToLeft).Column
   
   For zz = 2 To lngZ - 1
      cc = 1
      varM = Application.Match(Cells(zz, cI), _
         Range(Cells(zz + 1, cI), Cells(lngZ, cI)), 0)
      While IsNumeric(varM)
         cc = cc + cA
         Cells(zz + varM, 1).Resize(, cA).Copy Cells(zz, cc)
         If IsEmpty(Cells(1, cc)) Then _
            Cells(1, 1).Resize(, cA).Copy Cells(1, cc)
         Rows(zz + varM).Delete
          varM = Application.Match(Cells(zz, cI), _
            Range(Cells(zz + 1, cI), Cells(lngZ, cI)), 0)
      Wend
   Next zz
   With ActiveSheet
      If .AutoFilterMode Then .AutoFilterMode = False
   End With
   Cells(1, 1).AutoFilter
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort


  

Betrifft: AW: Tabelle mit VBA umstellen von: Erwin_Geer
Geschrieben am: 18.11.2009 12:58:36

Hallo Erich,

toll funktioniert so wie ich es brauche und meine nachfolgenden Makros ebenso.
Herzlichen Dank

Erwin


Beiträge aus den Excel-Beispielen zum Thema "Gleiche Werte nach rechts kopieren"