Listwiev Başlıklarını daraltma

[BYSERTTAS]

selamlar.
Aşağıkod ile Sayfadan Liste Alıyorum. Listwev başlıkları gelen veriye göre daraltılabilirmi?
yani liste alındığında başlık satırı ve listedeki tüm satırlar otomatik sığdırılacak şekilde daraltılabilirmi? nasıl yaparım?
Korhan hocamın hazırladığı örnek dosyayı ekliyorum. yardımcı olursanız sevinirim.

 

[Muzaffer Ali]

Merhaba.
Dosyanız ekte deneyiniz.

 

[Korhan Ayhan]

Alternatif;

Private Sub ComboBox1_Change()
    Dim X As Long, Y As Long
        
    Application.ScreenUpdating = False
        
    On Error Resume Next
    Set WS = Nothing
    Set WS = Sheets(Me.ComboBox1.Value)
    On Error GoTo 0
    
    With ListView1
        .ColumnHeaders.Clear
        .ListItems.Clear
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        .BackColor = &H80000005: ComboBox1.BackColor = &H80000005
        
        If Not WS Is Nothing Then
            Select Case WS.Name
                Case "Veri_1": .BackColor = &H80C0FF: ComboBox1.BackColor = &H80C0FF
                Case "Veri_2": .BackColor = &HFFFF80: ComboBox1.BackColor = &HFFFF80
                Case "Veri_3": .BackColor = &H80FFFF: ComboBox1.BackColor = &H80FFFF
            End Select
            
            With .ColumnHeaders
                For X = 1 To WS.Cells(5, WS.Columns.Count).End(1).Column
                    .Add , , WS.Cells(5, X), Int(WS.Cells(5, X).ColumnWidth) * 6
                Next
            End With
            
            For X = 6 To WS.Cells(WS.Rows.Count, 1).End(3).Row
                .ListItems.Add , , WS.Cells(X, 1).Value
                For Y = 2 To WS.Cells(5, WS.Columns.Count).End(1).Column
                    .ListItems(X - 5).SubItems(Y - 1) = WS.Cells(X, Y).Value
                Next
            Next
        End If
    End With

    Application.ScreenUpdating = True
End Sub

 

[BYSERTTAS]

Merhaba.
Dosyanız ekte deneyiniz.

Muzaffer bey Elinize Emeğinize Sağlık Benim Bilgisayarda çalışmadı.

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Bu satırda hata veriyor. ofis de windows da 64 bit ondan olabilirmi? yada bu kodu nereye alayım.

 

[Muzaffer Ali]

O satırı silin yerine bunu kullanın:

Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPtr

 

[BYSERTTAS]

Alternatif;

Private Sub ComboBox1_Change()
    Dim X As Long, Y As Long
       
    Application.ScreenUpdating = False
       
    On Error Resume Next
    Set WS = Nothing
    Set WS = Sheets(Me.ComboBox1.Value)
    On Error GoTo 0
   
    With ListView1
        .ColumnHeaders.Clear
        .ListItems.Clear
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        .BackColor = &H80000005: ComboBox1.BackColor = &H80000005
       
        If Not WS Is Nothing Then
            Select Case WS.Name
                Case "Veri_1": .BackColor = &H80C0FF: ComboBox1.BackColor = &H80C0FF
                Case "Veri_2": .BackColor = &HFFFF80: ComboBox1.BackColor = &HFFFF80
                Case "Veri_3": .BackColor = &H80FFFF: ComboBox1.BackColor = &H80FFFF
            End Select
           
            With .ColumnHeaders
                For X = 1 To WS.Cells(5, WS.Columns.Count).End(1).Column
                    .Add , , WS.Cells(5, X), Int(WS.Cells(5, X).ColumnWidth) * 6
                Next
            End With
           
            For X = 6 To WS.Cells(WS.Rows.Count, 1).End(3).Row
                .ListItems.Add , , WS.Cells(X, 1).Value
                For Y = 2 To WS.Cells(5, WS.Columns.Count).End(1).Column
                    .ListItems(X - 5).SubItems(Y - 1) = WS.Cells(X, Y).Value
                Next
            Next
        End If
    End With

    Application.ScreenUpdating = True
End Sub

Teşekkürler Korhan Hocam Bu kod işimi gördü. Ellerinize Sağlık. Sizlerin sayesinde Öğrenmeye devam inşallah