Vba'da bir sayaç ile döngü ekleme

Question

Sayfa1'de Excel çalışma sayfasında, Sayfa1 adlı bir sütun sütun var. Sütun A'nın sağındaki sütunlara karşılık gelen verilere sahibim. Bir satırdaki hücre miktarı değişir. Örneğin:

A, B, C, D, E, F, ...

John, 5, 10, 15, 20

Jacob, 2, 3

Jingleheimmer, 5, 10, 11

Ben kopyalamak çalışıyorum olduğunu aşağıdaki biçimde yeni bir çalışma, Sheet5, içine veriler:

A, B, C, D, E, F, ...

John 5

John 10

John 15

John 20

Jacob 2

Jacob 3

Jingleheimmer, 5

Jingleheimmer, 10

Jingleheimmer,

11 İlk iki kimlikleri üzerinde aşağıdaki kodu kopya yazdı. Kodun ikinci yarısını kopyalamaya ve hücreleri değiştirmeye devam edebilirdim, ancak 100'lerce kimlik sahibim. Bu çok uzun sürecek. Bir süreç tekrarlandığında bir döngü kullanmalıyım diye düşünüyorum. Bu tekrar eden kodu bir döngü haline getirmeme yardımcı olabilir misiniz?

Sub Macro5() 

Dim LastRowA As Integer 
Dim LastRowB As Integer 

''' Process of copying over first ID ''' 

'grab all data cells in B2 to the right 
With Sheets("Sheet1").Select 
Range("B2", Range("B2").End(xlToRight)).Select 
Selection.Copy 
End With 

'paste that data into the first empty cell of Column B in Sheet5 
With Sheets("Sheet5").Select 
Range("B1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End With 

'grab the corresponding ID in cell A2 
With Sheets("Sheet1").Select 
Range("A2").Select 
Application.CutCopyMode = False 
Selection.Copy 
End With 

'paste the corresponding ID into the first empty cell of Column A in Sheet5 
With Sheets("Sheet5").Select 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Range("A1").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
Application.CutCopyMode = False 
Selection.AutoFill Destination:=Range("A1:A" & LastRowB) 
End With 

''' Repeat that process for each row in Sheet1 ''' 

'grab all data cells in B3 to the right 
With Sheets("Sheet1").Select 
Range("B3", Range("B3").End(xlToRight)).Select 
Selection.Copy 
End With 

'paste that data into the first empty cell of Column B in Sheet5 
With Sheets("Sheet5").Select 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Range("B" & LastRowB + 1).Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End With 

'grab the corresponding ID in cell A3 
With Sheets("Sheet1").Select 
Range("A3").Select 
Application.CutCopyMode = False 
Selection.Copy 
End With 

'paste the corresponding ID into the first empty cell of column A in Sheet5 
'and autofill down to the last populated cell in column B 
With Sheets("Sheet5").Select 
LastRowA = Cells(Rows.Count, "A").End(xlUp).Row + 1 
Range("A" & LastRowB + 1).Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
Application.CutCopyMode = False 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Selection.AutoFill Destination:=Range("A" & LastRowA & ":A" & LastRowB) 
End With 

End Sub 

Answer 1

bu deneyin:

Sub test() 

Dim i As Integer 
Dim j As Integer 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim nRow As Integer 
Dim lRow As Integer 
Dim lCol As Integer 

Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet5") 
nRow = 1 

With ws1 

    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 

    For i = 1 To lRow 

     lCol = .Cells(i, .Columns.Count).End(xlToLeft).Column 

     For j = 2 To lCol 

      ws2.Cells(nRow, 1).Value = .Cells(i, 1).Value 
      ws2.Cells(nRow, 2).Value = .Cells(i, j).Value 
      nRow = nRow + 1 

     Next j 

    Next i 

End With 

End Sub 

O satırdaki değerlerle kadar son sütunda aracılığıyla, bir defada tabakanın bir her satır yoluyla isim ve ilişkili sayılar kopyalayana çalışır. Çok hızlı bir şekilde çalışmalı ve & sabit kopyalamaya gerek duymaz.

Answer 2

Bu, aradığınız şeyi yapmalıdır.

Sub test() 
Dim lastrow As Long, lastcol As Long 
Dim i As Integer, j as Integer, x as Integer 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 

Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet5") 

lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row 
x = 1 

With ws1 
    For i = 1 To lastrow 
     lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column 
     For j = 2 To lastcol 
      ws2.Cells(x, 1).Value = .Cells(i, 1).Value 
      ws2.Cells(x, 2).Value = .Cells(i, j).Value 
      x = x + 1 
     Next j 
    Next i 
End With 

End Sub