Expand existing Copy-Paste Loop: Loop through specific Columns based on Cell Value - Questionnaire

BuRnZz

New Member
Joined
Dec 9, 2020
Messages
27
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
I currently have multiple excel spreadhsheets that look like this:

current.png


The table is a questionnaire with answers from column C-F, C is the "worst" (letter N as in Not good), D the "second worst" (letter T), E the second best (letter W) and F the best (letter G as in Good).

To the right of this table are sentences that I copy to another Spreadsheet using an existing module, depending on where the "x" in the questionnaire is set (it always copies the sentence 9 rows to the right of the "x").

Now I want to modify my existing code to not just copy all the sentences from every row, but only copy 5 for each Worksheet. These 5 should be either the 5 "best" answers (5 from column F, meaning Good as answer in questionnaire, if there are less than 5 in that column then take the rest from column E until you have 5) or the 6 "worst" answers, meaning 5 from column C(letter N as in not good) and if there are less than 5 "X" in that column take the rest from column D (letter T). This way I want to copy the 5 best or worst answers for each Worksheet. The decision if the best or worst answers should be copied depends on one simple Cell Value (Cell K6) in each Worksheet. If K6 >70% take the best answers, if K6 is under 70%, take the worst answers.

This is my current module to copy all the answers to my new worksheet:


VBA Code:
Dim ws As Worksheet
Dim lr As Integer 'lastrow
Dim SpaltenIndex As Integer
Dim SheetNummer As Integer
Dim cl As Range 'cell
Dim rw As Range 'row
Dim Antwortrange As String
Dim WrkSht As Worksheet
Dim WrkShtCol As Sheets


'Create Destination Sheet
Sheets.Add
ActiveSheet.Name = "Handlungsempfehlungen"

'Set Questionnaire Answer Range to search through
Antwortrange = "C11:F400"

'ColumnIndex and SheetNumber
SpaltenIndex = 1
SheetNummer = 1

'Create Worksheet Collection with all the Questionnaire-Sheets
Set WrkShtCol = Worksheets(Array("AM AD - Anforderungsdefinition", "AM AA - Anforderunganalyse", "AM - Anforderungsdokumentation", "AM AV - Anforderungsvalidierung", "TM IT - Initiierung Test", "TM ZD - Zieldefinition", "TM TV - Testvorgehen", "TM TOB - Testobjektabgrenzung", "TM AS - Aufwandsschätzung", "TM TP - Testplanung", "TM TP - Testplanung", "TM TA - Testauftrag", "TM TS - Teststeuerung", "TM AO - Aufbauorganisation", "TM RM - Risikomanagement", "TM MI - Managementinformation", "TM AF - Abnahme Freigabe", "TM AT - Abschluss Test", "DT IT - Installationstest", "DT ST - Sicherheitstest", "OTP DT - Dokumententest", "OTP MT - Modultest", "OTP MIT - Modulintegrationstest", "OTP OO KT - OO Klassentest", "OTP OO KIT - OO Klassenintgrate", "OTP FT - Funktionstest", "OTP FIT - Funktionsintgratiotes", "OTP PIT - Produktintegratest", "OTP AT - Abnahmetest", "OTP ET - Ergonomietest", "OTP LPT - Last & Performance", "OTP GPT - Geschäftsprozesstest", "TUP TMK -Testumg Module Klassen", _
"TUP TUF - Testumgebung Funktion", "TUP TP - Testumgebung Prozesse", "ATP KM Konfigurationsmanagement", "ATP FAEM - Fehler Änderungs", "ATP DS - Datensicherheit", "ATP DSCH - Datenschutz", "ATP TEV -Testergebnisverwaltung", "ATP VG - Vertragsgestaltung"))
    
'MAIN LOOP: Take all sentences 9 rows to the right of each X in each Questionnaire and paste the value to the newly created sheet from above

For Each WrkSht In WrkShtCol

    For Each rw In WrkSht.Range(Antwortrange).Rows   
    For Each cl In rw.Cells
        
    lr = ws.Cells(ws.Rows.Count, SpaltenIndex).End(xlUp).Offset(1).Row
    If lr = 2 And ws.Range("A1") = "" And lr < 500 Then lr = 1
    'If lr = 2 And ws.Range("A2") = "" Then lr = 1
       
            If LCase(cl.Value) = "x" Then
                cl.Offset(0, 9).Copy Sheets("Handlungsempfehlungen").Cells(lr, SpaltenIndex)       
            End If
        Next cl
    Next rw



'If 1st row is empty in destination sheet, delete and shift rest up 
If Sheets("Handlungsempfehlungen").Cells(1, SpaltenIndex) = "" Then Sheets("Handlungsempfehlungen").Cells(1, SpaltenIndex).Delete Shift:=xlUp

'WrkShtCol(1).range("A2").Copy Worksheets("Handlungsempfehlungen").Cell(lr, SpaltenIndex)

Sheets("Handlungsempfehlungen").Cells(35, SpaltenIndex).Value = WrkShtCol(SheetNummer).Cells(2, 1)


SpaltenIndex = SpaltenIndex + 1
SheetNummer = SheetNummer + 1


End Sub

I hope you can help me, any tips would be greatly appreciated. Thank you so much in advance.

Edit - Expected Results:

If K6 is over 70% - find the 5 best answers (1st priority column F, if there are 5 "x" in column F, find those Cells and copy the value 9 rows to the right to the new sheet.

So if the questionnaire looks like this:
over70.png

The pasted table should look like this:
ans.png


And if the questionnaire is under 70%, do the same but for the worst (Column C & D, C being the worst, if there are not 5 "x" in C then take the rest from D (second worst))

Hope this helps
Thank you so much
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet including the sentences you want to copy. Better still, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet including the sentences you want to copy. Better still, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

here :)

The module is called myvbaproblem and creates the worksheet :)
 
Upvote 0
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet including the sentences you want to copy. Better still, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
Forgot to "reply" before, but done all of this
 
Upvote 0
I don't understand how you got some of the results in the "Result how it should be" sheet. For example, in the "TM IT - Initiierung Test" sheet, there is no data to the right of the x's but in the "Result how it should be" sheet, you have data in E1:E28 for that sheet. Where did that data come from? The only data in the "Result how it should be" sheet that seems to be following your request is in columns A, B and C which comes from AM AD - Anforderungsdefinition, AM AA - Anforderunganalyse and AM - Anforderungsdokumentation respectively. Please clarify in detail.
 
Upvote 0
I don't understand how you got some of the results in the "Result how it should be" sheet. For example, in the "TM IT - Initiierung Test" sheet, there is no data to the right of the x's but in the "Result how it should be" sheet, you have data in E1:E28 for that sheet. Where did that data come from? The only data in the "Result how it should be" sheet that seems to be following your request is in columns A, B and C which comes from AM AD - Anforderungsdefinition, AM AA - Anforderunganalyse and AM - Anforderungsdokumentation respectively. Please clarify in detail.
Ye sorry I only did the "how it should be version" for the first 3 Sheets and not for all 40, but the three should be enough to understand with the explanation in the steps (or at least i hoped so :P)
Should I do more than 3 sheets?
 
Upvote 0
Three sheets are enough to give me a start.
 
Upvote 0
Delete the two sample sheets that show the results. In cell K6 of most of your sheets you have a formula that is returning an error. Either fix the formula to return a valid percentage or manually enter the percentage otherwise the macro will return an error because there is no value to compare. Try this macro.
VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, lCol As Long
    If Not Evaluate("isref('" & "Handlungsempfehlungen" & "'!A1)") Then
        Sheets.Add(before:=Sheet1).Name = "Handlungsempfehlungen"
        Set desWS = Sheets("Handlungsempfehlungen")
    Else
        Set desWS = Sheets("Handlungsempfehlungen")
        desWS.UsedRange.ClearContents
    End If
    For Each ws In Sheets
        If ws.Name <> "Handlungsempfehlungen" And ws.Name <> "Steps" And ws.Name <> "Changelog" Then
            With ws
                lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
                LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                If .Range("K6") >= 0.7 Then
                    If WorksheetFunction.CountIf(.Range("F11:F" & LastRow), "x") >= 5 Then
                        .Range("A2").AutoFilter 6, "x"
                        desWS.Cells(1, lCol) = ws.Name
                        .Range("F11:F" & LastRow).Offset(, 9).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, lCol).End(xlUp).Offset(1)
                        .Range("A2").AutoFilter
                    Else
                        .Range("A2").AutoFilter 6, "x"
                        desWS.Cells(1, lCol) = ws.Name
                        .Range("F11:F" & LastRow).Offset(, 9).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, lCol).End(xlUp).Offset(1)
                        .Range("A2").AutoFilter
                        .Range("A2").AutoFilter 5, "x"
                        .Range("E11:E" & LastRow).Offset(, 9).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, lCol).End(xlUp).Offset(1)
                        .Range("A2").AutoFilter
                    End If
                Else
                    If WorksheetFunction.CountIf(.Range("C11:C" & LastRow), "x") >= 5 Then
                        .Range("A2").AutoFilter 3, "x"
                        desWS.Cells(1, lCol) = ws.Name
                        .Range("C11:C" & LastRow).Offset(, 9).SpecialCells(xlCellTypeVisible).Copy desWS.Range("A2")
                        .Range("A2").AutoFilter
                    Else
                        .Range("A2").AutoFilter 4, "x"
                        desWS.Cells(1, lCol) = ws.Name
                        .Range("C11:C" & LastRow).Offset(, 9).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, lCol).End(xlUp).Offset(1)
                        .Range("A2").AutoFilter
                        .Range("A2").AutoFilter 5, "x"
                        .Range("D11:D" & LastRow).Offset(, 9).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(desWS.Rows.Count, lCol).End(xlUp).Offset(1)
                        .Range("A2").AutoFilter
                    End If
                End If
            End With
        End If
    Next ws
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Rows("7:" & LastRow).Delete
        .Columns(1).Delete
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top