Thema Datum  Von Nutzer Rating
Antwort
09.08.2019 12:36:40 Matthias
NotSolved
09.08.2019 12:55:38 Torsten
NotSolved
09.08.2019 15:33:39 Gast26624
NotSolved
09.08.2019 15:45:52 Torsten
NotSolved
09.08.2019 15:56:13 Gast16243
NotSolved
12.08.2019 11:13:03 Torsten
NotSolved
Rot Spalten löschen
12.08.2019 10:51:07 Gast70117
NotSolved
12.08.2019 11:23:50 Gast54642
NotSolved
12.08.2019 15:25:15 Gast70117
NotSolved

Ansicht des Beitrags:
Von:
Gast70117
Datum:
12.08.2019 10:51:07
Views:
671
Rating: Antwort:
  Ja
Thema:
Spalten löschen
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Option Explicit
 
Sub Mein_Übertrag_Montagefirma()
Dim rngU As Range       'tatsächlich genutzter Bereich
Dim rngB As Range       'iteriere durch Spalte B
Dim rngT As Range       'zu kopierender Bereich
Dim loAnz As Long       'Zählen
Dim loLetzte As Long    'letzte befüllte Zeile
 
   'wer ausschaltet sollte auch wieder einschalten
   Application.ScreenUpdating = False
     
   With Worksheets("Montagefirma")
      .Range("A1:AA" & .Cells(.Rows.Count, 1).End(xlUp).Row).Clear
    End With
 
   With Worksheets("Terminplan")
      .Columns("A:B").Hidden = False
      'tatsächlich genutzter Bereich
      Set rngU = Range(.Cells(1), .Cells(.Cells.Find("*", _
         .Cells(1), -4123, 2, 1, 2, False).Row, _
         .Cells.Find("*", .Cells(1), -4123, 2, 2, 2, False).Column))
      For Each rngB In rngU.Columns("B").Cells
         'Abgleich
         If rngB.Text = .Range("F6").Text Then
            'Zählen
            loAnz = loAnz + 1
            'zu kopierender Bereich
            Set rngT = rngU.Rows(rngB.Row)
            Set rngT = rngT.Offset(, 2).Resize(, rngT.Columns.Count - 2)
            rngT.Copy
            With Worksheets("Montagefirma")
               If .Cells(1) = "" Then
                  loLetzte = 1
               Else
                  loLetzte = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row + 1
               End If
              .Cells(loLetzte, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
              .Cells(loLetzte, "A").PasteSpecial Paste:=xlPasteFormats
            End With
         End If
      Next rngB
          
      Application.CutCopyMode = False
      .Columns("A:B").Hidden = True
          
   End With
    
   MsgBox "Es wurden " & loAnz & " Sätze übertragen."
   Application.ScreenUpdating = True
 
End Sub

 


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
09.08.2019 12:36:40 Matthias
NotSolved
09.08.2019 12:55:38 Torsten
NotSolved
09.08.2019 15:33:39 Gast26624
NotSolved
09.08.2019 15:45:52 Torsten
NotSolved
09.08.2019 15:56:13 Gast16243
NotSolved
12.08.2019 11:13:03 Torsten
NotSolved
Rot Spalten löschen
12.08.2019 10:51:07 Gast70117
NotSolved
12.08.2019 11:23:50 Gast54642
NotSolved
12.08.2019 15:25:15 Gast70117
NotSolved