Thema Datum  Von Nutzer Rating
Antwort
08.06.2020 20:18:18 Bernhard
NotSolved
08.06.2020 21:12:03 AlterDresdner
NotSolved
09.06.2020 09:14:40 Gast87195
NotSolved
09.06.2020 22:04:22 Bernhard
NotSolved
Rot Makro gesucht
 10.06.2020 11:34:27 Martin
*****
Solved
10.06.2020 11:59:11 Martin
NotSolved
16.06.2020 15:00:40 Bernhard
NotSolved
16.06.2020 17:17:49 Bernhard
NotSolved

Ansicht des Beitrags:
Von:
Martin		 Datum:
10.06.2020 11:34:27		 Views:
678		 Rating:
     
Antwort:
 Nein
Thema:
Makro gesucht

Hallo Bernhard,

hier ist mein Lösungsansatz

 

Lg. Martin

Option Explicit

Public out As Range 'erste Zelle in Ausgabetabelle
Public ctZ As Integer 'Zeile in Ausgabetabelle
Public ctS As Integer 'Spalte in Ausgabetabelle


Sub durchlauf()
Dim firstpos As Range 'erste Zelle in Eingabetabelle
Dim ze As Integer 'Zeile in Eingabetabelle
Dim sp As Integer 'Spalte in Eingabetabelle
Dim aktSP As String 'Inhalt erste Zeile der aktuellen Spalte
Dim aktZE As String 'Inhalt erste Spalte der ersten Zeile
Dim wert As String 'Inhalt der aktuellen Zelle


Set firstpos = Sheets("input").Range("A1")
Set out = Sheets("output").Range("A1")
ze = 0
sp = 0
ctZ = 0
ctS = 0
While firstpos.Offset(0, sp + 1).Value <> 0 'solange es spalten gibt
    sp = sp + 1
    While firstpos.Offset(ze + 1, 0).Value <> 0 'solange es zeilen gibt
        ze = ze + 1
        wert = firstpos.Offset(ze, sp).Value
        If wert <> Str("0") And wert <> "" Then 'wenn etwas in Zeile Zeile steht
        aktSP = firstpos.Offset(0, sp).Value
        aktZE = firstpos.Offset(ze, 0).Value
        ausgabe aktSP, aktZE, wert
        End If
    Wend
ze = 0
ctS = 0
ctZ = ctZ + 1
Wend
End Sub

Function ausgabe(ze, sp, wert)
If ze <> Sheets("output").Cells(ctZ + 1, 1).Value Then
'neue Zeile
out.Offset(ctZ, 0).Value = ze
ctS = ctS + 1
End If
'fortsetzung
out.Offset(ctZ, ctS).Value = sp
out.Offset(ctZ, ctS + 1).Value = wert
ctS = ctS + 2
End Function

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
08.06.2020 20:18:18 Bernhard
NotSolved
08.06.2020 21:12:03 AlterDresdner
NotSolved
09.06.2020 09:14:40 Gast87195
NotSolved
09.06.2020 22:04:22 Bernhard
NotSolved
Rot Makro gesucht
 10.06.2020 11:34:27 Martin
*****
Solved
10.06.2020 11:59:11 Martin
NotSolved
16.06.2020 15:00:40 Bernhard
NotSolved
16.06.2020 17:17:49 Bernhard
NotSolved