Kopieren von Daten aus einem Arbeitsblatt bis zu einer Bedingung

Question

Ich habe ein Arbeitsblatt, das Daten in Spalte B bis Spalte D enthält. Ich möchte die Daten von B4 bis zum Zellenwert kopieren, der Leerzeichen davor hat und es in einem separaten einfügen Blatt und ändern Sie das Blatt als der Wert B4 und dann muss es die nächsten Zellenwerte bis zum Zellenwert mit Leerzeichen vor dem kopieren und es geht weiter, bis Spalte B leere Zellen hat.

Zusätzlich muss ich in Spalte A die Seriennummer in Bezug auf die Daten ohne Leerzeichen in der Anfangsphase eingeben. Ich habe die Eingabe und das erwartete Ausgabebild für Ihre Referenz beigefügt.

Eingang:

erwartete Ausgabe:

bitte zu diesem Thema helfen.

Answer 1

Ihr Blatt Unter der Annahme, ist wie folgt:

Geben Sie die folgende Formel in den Cell A4

=IF(LEFT(B4,1)<>" ",COUNTA($A$2:A3)+1-COUNTBLANK($A$2:A3),"") 

Ziehen/Kopieren unten Formel je nach Bedarf.

Wenn Sie einen VBA-Lösung suchen, sollten folgende Arbeiten:

Sub Demo() 
    Dim ws As Worksheet 
    Dim lastRow As Long, index As Long, i As Long 
    Dim rng As Range 

    index = 1 
    Set ws = ThisWorkbook.Sheets("Sheet1") '---->change the sheet name as required 
    lastRow = ws.Cells(Rows.count, "B").End(xlUp).Row 
    Set rng = ws.Range("B4:B" & lastRow) 
    For i = 4 To lastRow 
     If Left(ws.Cells(i, 2).Value, 1) <> " " Then 
      ws.Cells(i, 1).Value = index 
      index = index + 1 
     End If 
    Next i 
End Sub 

_______________________________________________________________________________

EDIT 1: Kopieren Sie Daten Sheet1-Sheet2 und dann Seriennummern hinzufügen .

Sub Demo() 
    Dim ws1 As Worksheet, ws2 As Worksheet 
    Dim lastRow As Long, index As Long, i As Long 
    Dim rng As Range 

    index = 1 
    Set ws1 = ThisWorkbook.Sheets("Sheet1") '---->change the sheet name as required 
    Set ws2 = ThisWorkbook.Sheets("Sheet2") 
    lastRow = ws1.Cells(Rows.count, "B").End(xlUp).Row 
    ws1.Range("B2:D" & lastRow).Copy Destination:=ws2.Range("B2") 
    Set rng = ws2.Range("B4:B" & lastRow) 
    For i = 4 To lastRow 
     If Left(ws2.Cells(i, 2).Value, 1) <> " " Then 
      ws2.Cells(i, 1).Value = index 
      index = index + 1 
     End If 
    Next i 
End Sub 

_______________________________________________________________________________

EDIT 2:

Sub Demo() 
    Dim srcWS As Worksheet, destWS As Worksheet 
    Dim lastRow As Long, index As Long, i As Long 
    Dim copyRng As Range, rng1 As Range, rng2 As Range 

    index = 1 
    Set srcWS = ThisWorkbook.Sheets("Sheet1") '---->change the sheet name as required 
    lastRow = srcWS.Cells(Rows.count, "B").End(xlUp).Row 
    Set rng1 = srcWS.Cells(4, 2) 
    For i = 4 To lastRow 
     If Left(srcWS.Cells(i, 2).Value, 1) <> " " Then 
      srcWS.Cells(i, 1).Value = index 
      index = index + 1 
      If i <> 4 Then 
       Set rng2 = srcWS.Cells(i - 1, 4) 
       Set destWS = Sheets.Add(After:=Sheets(Sheets.count)) 
       srcWS.Range(rng1, rng2).Copy Destination:=destWS.Range("B4") 
       Set rng1 = srcWS.Cells(i, 2) 
      End If 
     End If 
    Next i 
    Set rng2 = srcWS.Cells(lastRow, 4) 

    Set destWS = Sheets.Add(After:=Sheets(Sheets.count)) 
    srcWS.Range(rng1, rng2).Copy Destination:=destWS.Range("B4") 

End Sub