4 Code zusammenfassen

[DietmarD]

Hallo zusammen,

ich habe hier einen Code den ich vier mal habe in dem nur der Range Bereich zum kopieren ein andere ist. Um meine Daten zu übertragen führe somit vier Code aus.

Wie kann ich das mit einem Code erreichen.

hier die 4 Range
 
A7:G17
I7:M17
A25:G35
I25:M35

Code:

 Sub OrgaMaster()
'
'
'
'
Dim wb1 As Workbook
Dim wb1pfad As String
Dim wb1name As String
Dim i As Long
Dim zeile As Long
Dim ende As Long
Dim bwbopen As Boolean
Dim loLetzte As Long

wb1pfad = "\\sdegla00002\CEC\Auswertung\Übersicht der Ausfälle\"
wb1name = "Master SL3.xlsm"


   
Range("I7:M17").Select
   Selection.Copy
   
    Workbooks.Open (wb1pfad & wb1name)
   Sheets("orga. Ausfälle").Select
   Cells([a65536].End(xlUp).Row + 1, 1).Activate
   
         loLetzte = Sheets("orga. Ausfälle").UsedRange.SpecialCells(xlCellTypeLastCell + 1).Row
   
   
   
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
   :=False, Transpose:=False
  Range("h8").Select
   
   
         
Range("A5").Select
ende = Range("A65536").End(xlUp).Row
Do Until i = ende
If ActiveCell.Value = "" Then
   ActiveCell.EntireRow.Delete
Else
   ActiveCell.Offset(1, 0).Select
End If
i = i + 1
Loop
       
       Workbooks("Master SL3.xlsm").Close SaveChanges:=True
End Sub

Danke für eure Antworten!

[BoskoBiati]

Hi,

aus dem Code ist nicht ersichtlich, wo die Daten hinkopiert werden sollen. Löschen von Zeilen immer von unten nach oben!

Als ersten Ansatz:

Code:

Sub OrgaMaster()
'
'
'
'
Dim wb1 As Workbook
Dim wb1pfad As String
Dim wb1name As String
Dim i As Long
Dim zeile As Long
Dim ende As Long
Dim bwbopen As Boolean
Dim loLetzte As Long

wb1pfad = "\\sdegla00002\CEC\Auswertung\Übersicht der Ausfälle\"
wb1name = "Master SL3.xlsm"

 With Workbooks.Open(wb1pfad & wb1name).Sheets("orga. Ausfälle")
     loLetzte = .UsedRange.SpecialCells(xlCellTypeLastCell + 1).Row
    Range("I7:M17").Copy

      Cells([a65536].End(xlUp).Row + 1, 1).Activate  ??????????????

      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False

   ende = Cells(Rows.Count, 1).End(xlUp).Row
   i = ende
   Do Until i = 5
       If Cells(i, 1) = "" Then Rows(i).EntireRow.Delete
       i = i - 1
   Loop
       
       Workbooks("Master SL3.xlsm").Close SaveChanges:=True
End Sub

[Rabe]

Hi,

Code:

   ende = Cells(Rows.Count, 1).End(xlUp).Row
   i = ende
   Do Until i = 5
       If Cells(i, 1) = "" Then Rows(i).EntireRow.Delete
       i = i - 1
   Loop

Jetzt kann ichs auch mal kürzer machen:

   Ende = Cells(Rows.Count, 1).End(xlUp).Row
   For i = Ende To 5 Step -1
       If Cells(i, 1) = "" Then Rows(i).EntireRow.Delete
   Next i

[atilla]

Hallo,

der TE arbeitet im oberen bereich mit specialCells und sollte das beim Löschen auch tun.

Statt dieser Zeilen:

Code:

Do Until i = ende
If ActiveCell.Value = "" Then
  ActiveCell.EntireRow.Delete
Else
  ActiveCell.Offset(1, 0).Select
End If

reicht dann

Code:

Range("A5:A" & ende).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

[DietmarD]

Hallo zusammen,

vielen Dank für eure Hilfe, hatte allerdings noch keine Zeit dies zu testen.
Feedback kommt in jedem Fall.

Danke!

[snb]

Code:

Sub M_snb
  with getobject("\\sdegla00002\CEC\Auswertung\Übersicht der Ausfälle\Master SL3.xlsm")
     with .sheets("orga. Ausfälle").cells(rows.count,1).end(xlup)
       .offset(1).resize(10,13)=range("A7:M17").value
       .offset(11).resize(10,13)=range(A25:M35").value
     end with
     .close -1
   end with

   cells(1).currentregion.offset(4).entirerow.delete
End Sub