Automatiseren commentaren file

[leslieE]

Hey,

Heb het volgende doc (zie blijlage).
Heb 3 sheets:
1: Received: dit is een sheet die we krijgen met de commentaren, vraagnr en ID nummer.
2: Output: dit is hoe het er moet uitzien
3: Codes: File met codes per vraag

Kan iemand me helpen om de output automatisch te verkrijgen op basis van sheet received en sheet codes?
Misschien ook rekening mee houden dat het aantal lijnen kan veranderen, naargelang de lengte van de vragenlijst.

Bedankt

Groetjes

Leslie

 

[leslieE]

Omdat we het in die format nodig hebben. Een kruistabel kan ik later niet gebruiken, want moet die output in een statistisch programma importeren.
Dus heb het echt nodig, zoals het er staat

 

[Wigi]

Sub wigi()
    
    Dim l As Long
    
    With Sheets("RECEIVED")
        l = .Range("D" & Rows.Count).End(xlUp).Row
        .[F2].Resize(l - 1).Formula = "=RC3&""§""&RC4"
    End With
    
    With Sheets("OUTPUT")
    
        .Cells.ClearContents
        
        .Parent.PivotCaches.Add(xlDatabase, "RECEIVED!R1C3:R" & l & "C4").CreatePivotTable TableDestination:="'" & .Name & "'!R1C1", TableName:="PivotTable2"
        .PivotTables("PivotTable2").AddFields RowFields:="ID", ColumnFields:="question"
        .PivotTables("PivotTable2").PivotFields("ID").Orientation = xlDataField
        
        .UsedRange.Interior.ColorIndex = xlNone
        
        With .[A1].CurrentRegion
            .Copy
            .Cells(1, 1).PasteSpecial xlValues
            .Rows(1).Delete
            .Cells(Rows.Count, "A").End(xlUp).EntireRow.Delete
            .Cells(1, Columns.Count).End(xlToLeft).EntireColumn.Delete
            
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .SpecialCells(2, 1).Formula = "=INDEX(RECEIVED!R1C5:R" & l & "C5,MATCH(" & .Name & "!RC1&""§""&" & .Name & "!R1C,RECEIVED!R1C6:R" & l & "C6,0))"
                .Value = .Value
            End With
            
        End With
    
    End With
    
End Sub

Wigi

 

[leslieE]

Hey,

Hier loopt de macro altijd vast

.PivotTables("PivotTable2").PivotFields("ID").Orientation = xlDataField

Moet ik iets speciaals doen?
want na dit stopt hij altijd.

Groetjes
Leslie

 

[snb]

Ik zou beginnen met een standaardisatie.
Je gebruikt nu voor iedere vraag 3 verschillende codes bijv:

7bco 7.bco. o_q7b

Als je dat gestandaardiseerd hebt hebt is deze macro voldoende:

Sub tst()
  sq = Sheets("codes").UsedRange.Columns(9)
  Sheets("Blad1").Cells(1, 2).Resize(, UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
  Sheets("Blad1").Cells(1, 1) = "ID"
  sq = Sheets("Received").UsedRange
    
  For j = 2 To UBound(sq)
    With Sheets("Blad1").Cells(Rows.Count, 1).End(xlUp).Offset(1)
      .Value = sq(j, 3)
      .Offset(, Sheets("Blad1").Rows(1).Find("o_q" & sq(j, 4)).Column - 1) = sq(j, 5)
    End With
  Next
End Sub

 

[Wigi]

Hey,

Hier loopt de macro altijd vast

.PivotTables("PivotTable2").PivotFields("ID").Orientation = xlDataField

Moet ik iets speciaals doen?
want na dit stopt hij altijd.

Groetjes
Leslie

Je hebt de hinderlijke spatie achter de kolomtitel question al weggehaald?

 

[leslieE]

Bij gebruik van deze macro :

Sub tst()

Dan krijg ik een lijn per ID.
Zou graag hebben dat alle commentaren van dezelfde ID op 1 lijn komen.

Is dit mogelijk?

 

[snb]

Ja hoor:

Sub tst()
  sq = Sheets("codes").UsedRange.Columns(9)
  Sheets("Blad1").Cells(1, 2).Resize(, UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
  Sheets("Blad1").Cells(1, 1) = "ID"
  sq = Sheets("Received").UsedRange
    
  For j = 2 To UBound(sq)
    With Sheets("Blad1").Cells(Rows.Count, 1).End(xlUp)
      With .Offset(iif(.value=sq(j,3),0,1))
         .Value = sq(j, 3)
         .Offset(, Sheets("Blad1").Rows(1).Find("o_q" & sq(j, 4)).Column - 1) = sq(j, 5)
      End With
    End With
  Next
End Sub