Excel'de tablo oluşturma Farklı Sayfalardaki Verileri Çekerek

Question

1,2,3,4 numaralı farklı sayfalardan veri çekerek "Verimlilik" sayfasında bir tablo oluşturmaya çalışıyorum .... Tablo oluşturmaya çalışırken 8 sütun var. Bunlardan biri tarih. Tarih, yalnızca G4 hücresinin bir hücresinde ve her sayfadaki aynı noktadadır. Diğer sütunlar, satır 9'dan başlayarak, B, C, D, E, F, O ve Q sütunlarından gelir. 1 ila 2 ila 3 arası sayfalardan giderken sütunların boyutu değişebilir. Sadece verileri kopyalamak istiyorum ve başka bir şey yok. Satır 20'ye kadar bazı biçimlendirmeler vardır, ancak yalnızca veri olduğu kadar sabit sayıda satır kopyalamak istemez. Bu bilgiyi "Verimlilik" sayfasına yapıştırdığımda, sadece verileri değil, biçimlendirmeyi istiyorum. Ayrıca tarih sütununun uzunluğunu diğer veri noktalarının uzunluğuna ve alındığı "tarih" sayfasına eşleştirmek istiyorum. Ayrıca, bir satırın sadece bir kez, tablonun ilk satırında oluşturulduğunu ve öğelerin "Tarih" ve B, C, D, E, F, O ve Q sütunlarının 8. satırlarını da istiyorum. her "tarih" sayfasında aynıdır, ancak sadece "Verimlilik" sayfasındaki tablo başlığı için bir kez gerekir. Bunu anlayabilmem için bana yardım edebilir mi lütfen?

Teşekkür

'

Sub DataTable() 

Dim wsTable As Worksheet 
Set wsTable = Worksheets("Efficiency") 'change as needed 

Dim ws As Worksheet 

For Each ws In ThisWorkbook.Worksheets 

    Select Case ws.Name 

     Case Is = "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15" 

      With ws 

       Dim rngData As Range 
       Set rngData = Union(.Range("B:F"), .Range("O:O"), .Range("Q:Q")) 

       Dim lRow As Long 
       Dim rCheck As Range 
       For Each rCheck In Intersect(rngData, .Rows(1)) 

        If .Cells(.Rows.Count, rCheck.Column).End(xlUp).Row > lRow Then 
         lRow = .Cells(.Rows.Count, rCheck.Column).End(xlUp).Row 
        End If 

       Next 

         Dim dDate As Date 
         dDate = .Range("G4").Value 


        With wsTable 

        .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(lRow, 1).Value = dDate 
        ws.Range("B9:F" & lRow).Copy 
        .Range("B" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues 
        ws.Range("O9:O" & lRow).Copy 
        .Range("O" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues 
        ws.Range("Q9:O" & lRow).Copy 
        .Range("Q" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues 

       End With 

      End With 

    End Select 

Next 

End Sub 

'

Answer 1

ben yapmaya çalıştığını anlamak düşünüyorum. Bence bunu gerekenden biraz daha zorlaştırmaya çalışıyorsun. İşte istediğini elde etmek için bazı döngüler kullanarak oluşturduğum bir kod. Sayfanın tarihini bir değişkene kopyalar. Ardından, Tarih'i ilk sütuna koyup B - I başlıklarını getirdim. Buna göre ayarlayabilirsiniz.

Dim rowDate As Date 

Sheets("Sheet1").Select 
rowDate = Cells(4, 7) 

Range("B9").Select 
' Copy the header rows & make the word Date the first column 
Sheets("Efficiency").Range("A1") = "Date" 
Range("B8:F8").Copy 
Sheets("Efficiency").Range("B1").PasteSpecial xlPasteValues 
Range("O8").Copy 
Sheets("Efficiency").Range("H1").PasteSpecial xlPasteValues 
Range("Q8").Copy 
Sheets("Efficiency").Range("I1").PasteSpecial xlPasteValues 

' Cycle throught the sheets and copy the data 
' Each array item is the sheet name. 

Dim SheetArray(4) As String 
SheetArray(0) = "Sheet1" 
SheetArray(1) = "Sheet2" 
SheetArray(2) = "Sheet3" 
SheetArray(3) = "Sheet4" 

Dim EffRow As Integer ' Keep track of the correct row on the Efficiency sheet 
Dim EffCell As String ' Track the cell for effeciency 
EffRow = 2 
For i = 0 To 3 

    Sheets(SheetArray(i)).Select 
    rowDate = Cells(4, 7) 
    Range("B9").Select 

    ' Loop until a blank cell is reached 
    Do While Not (IsEmpty(ActiveCell)) 
     EffCell = "A" & EffRow 
     Sheets("Efficiency").Range(EffCell) = rowDate 
     Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 5)).Copy 
     EffCell = "B" & EffRow 
     Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues 
     ActiveCell.Offset(0, 13).Copy 
     EffCell = "H" & EffRow 
     Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues 
     EffCell = "I" & EffRow 
     Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues 
     EffRow = EffRow + 1 
     ActiveCell.Offset(1, 0).Activate 
    Loop 
Next i 

End Sub

Umarım bu doğru yönde yönlendirir.