Daten Textfeldern zuordnen + Word-Export

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Guten Abend Uwe,
eigentlich wollte ich gerade ins Bett ... aber nun kam noch Dein Lösungsansatz, den ich mir nicht entgehen lassen möchte. Zunächst sieht das schonmal alles sehr sehr gut aus! ... wenngleich mir ein paar DInge ins Auge fallen:
- im Word-Sheet werden Test-Titel und Test-Art jeweils um eine Zeile versetzt ausgegeben; liegt das am Counter? (habs noch nicht experimentiert ..)
- Du hast in meinen DropDown-Abfragen keine Befehle eingesetzt sondern nur ein kleines SelectionChange Event eingefügt ... es arbeitet korrekt, aber die Performance der ganzen Mappe ist beträchtlich gesunken; jede beliebige Eingabe erzeugt harte Delays was bei 18 Psychologen, die die Liste tgl. simultan nutzen mühsam wird ... (btw.: überwacht das SC-Event auch die DropDowns in Spalte A? ... was ja unnötig wäre ...)
- apropos 18: angenommen Kollege A exportiert und holt sich die Textfelder aus dem Sheet als Vorlage in seinen Gutachten, um die (verschlüsselten) Testergebnisse dazuzupacken und Kollegen B und C starten derweil den selben Vorgang ... wird dann der Export im Sheet von Kollege A durch den ClearContent Befehlt entfernt oder bleibt der für Kollege A sichtbar?
Wäre die .find Lösung evtl. ressourcenschonender? Eine Übergabe an Word scheint mir zudem auch geeigneter, da der exportierte Content dann bei allen separat verfügbar wird. Was meinst Du? Bin Dir für Dein Engagement wirklich außerordentlich dankbar. Auf jeden Fall die absolut richtige Richtung.
Viele Grüße
Kalle

Sub TextMarker1() Dim i As Long, lz As Long Tabelle20.Range("A3:C22").ClearContents With Tabelle1 For i = 10 To 29 lz = Tabelle20.Cells(Tabelle20.Rows.Count, 1).End(xlUp).Row + 1 If .Cells(mz, i) = "e" Then Tabelle20.Cells(lz, 1) = Tabelle9.Cells(i - 6, 1) Tabelle20.Cells(lz, 2) = Tabelle9.Cells(i - 6, 2) Tabelle20.Cells(lz, 3) = Tabelle9.Cells(i - 6, 3) End If Next i End With End Sub

Sub TextMarker1() Dim i As Long, lz As Long, arrAusgabe, j As Long, k As Long Tabelle20.Range("A3:C22").ClearContents With Tabelle1 For i = 10 To 29 lz = Tabelle20.Cells(Tabelle20.Rows.Count, 1).End(xlUp).Row + 1 If .Cells(mz, i) = "e" Then k = k + 1 End If Next i ReDim arrAusgabe(k - 1, 2) For i = 10 To 29 If .Cells(mz, i) = "e" Then arrAusgabe(j, 0) = Tabelle9.Cells(i - 6, 1) arrAusgabe(j, 1) = Tabelle9.Cells(i - 6, 2) arrAusgabe(j, 2) = Tabelle9.Cells(i - 6, 3) j = j + 1 End If Next i Tabelle20.Range("A3").Resize(UBound(arrAusgabe), UBound(arrAusgabe, 2) + 1) = arrAusgabe End With End Sub

Hallo Kalle,
Excel nach Word exportieren geht nicht. Was unter Beachtung der Zuweisungen an richtiger Stelle machbar ist, sind copy/paste Vorgänge von Texten und Elementen.
Packe bitte beide Dateien, wo der Fehler für mich auslesbar ist, in eine Zip Datei und lade Diese hoch. Mal sehen was ich / ob ich was machen kann, um über Umwege vielleicht was zu erreichen. Ich habe heute Vormittag etwas mehr Zeit als gedacht, da ein Schüler sich krankgemeldet hat. Die Kombi, welche ich dir geschickt habe arbeitet ohne Fehler.
Das ist mir eben beim genaueren Lesen deiner angepassten Prozeduren aufgefallen:
So wie du das Einlesen der Zeilen machst entstehen Leerzeilen. Folge sind Unsauberkeiten in der Ausgabe der Tabelle. Ändere es so in den anderen Prozeduren adäquat:


Sub TextMarker_psy()
Dim i As Long, lz As Long, j As Long, k As Long
Tabelle2.Range("A2:C30").ClearContents
With Tabelle1
For i = 12 To 14
lz = Tabelle2.Cells(Tabelle2.Rows.Count, 1).End(xlUp).Row + 1
If .Cells(mz, i) = "e" Then
k = k + 1
End If
Next i
For i = 17 To 22
lz = Tabelle2.Cells(Tabelle2.Rows.Count, 1).End(xlUp).Row + 1
If .Cells(mz, i) = "e" Then
k = k + 1
End If
Next i
For i = 24 To 29
lz = Tabelle2.Cells(Tabelle2.Rows.Count, 1).End(xlUp).Row + 1
If .Cells(mz, i) = "e" Then
k = k + 1
End If
Next i
ReDim arrAusgabe(k, 1)
For i = 12 To 14
If .Cells(mz, i) = "e" Then
arrAusgabe(j, 0) = Tabelle9.Cells(i - 6, 1)
arrAusgabe(j, 1) = Tabelle9.Cells(i - 6, 2)
j = j + 1
End If
Next i
For i = 17 To 22
If .Cells(mz, i) = "e" Then
arrAusgabe(j, 0) = Tabelle9.Cells(i - 6, 1)
arrAusgabe(j, 1) = Tabelle9.Cells(i - 6, 2)
j = j + 1
End If
Next i
For i = 24 To 29
If .Cells(mz, i) = "e" Then
arrAusgabe(j, 0) = Tabelle9.Cells(i - 6, 1)
arrAusgabe(j, 1) = Tabelle9.Cells(i - 6, 2)
j = j + 1
End If
Next i
Tabelle2.Range("A2").Resize(UBound(arrAusgabe) + 1, UBound(arrAusgabe, 2) + 1) = arrAusgabe
End With
End Sub

Gruß Uwe

With ThisWorkbook.Worksheets("Testbedarf BvB") Range("AF5").FormulaLocal = "=SUMMENPRODUKT(--(H5>DATWERT(""01 / 10 / 2021"")))" Range("AF5:AF" & Cells(Rows.Count, "A").End(xlUp).Row).FillDown End with

Sub AusgabeInWord() Dim Pfad As String, WdApp As Object, wdDok As Object Pfad = "\\fs02\user$\jaeger\Eigene Dateien\__Excel_DEV\Testexport.docx" Tabelle2.Range("A1:B" & UBound(arrAusgabe) + 1).Copy Set WdApp = CreateObject("Word.Application") Set wdDok = WdApp.Documents.Open(Filename:=Pfad, ReadOnly:=False) WdApp.Visible = True WdApp.Selection.PasteExcelTable False, False, False Set wdDok = Nothing Set WdApp = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Daten Textfeldern zuordnen + Word-Export

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread