VBA Code:
Sub CopyDataAndCreateChart()
Dim folderPath As String
Dim file As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim destRange As Range
Dim chartRange As Range
Dim chtShape As Shape
Dim cht As Chart
Dim wb As Workbook
Dim ws As Worksheet
Dim cell As Range
' Prompt user to select the folder containing the files
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
folderPath = .SelectedItems(1)
End With
' Create a new workbook
Set wbDest = Workbooks.Add
' Set the destination worksheet
Set wsDest = wbDest.Sheets(1)
' Define the destination range for pasting data
Set destRange = wsDest.Range("A1")
' Loop through each file in the selected folder
file = Dir(folderPath & "\*.csv") ' Modify the file extension if needed
Do While file <> ""
' Open the source workbook
Set wbSource = Workbooks.Open(folderPath & "\" & file)
' Rename the source sheet to "Sheet1"
Set wsSource = wbSource.Sheets(1)
wsSource.Name = "Sheet1"
' Find the last row and column of the data in the source worksheet
Dim lastRow As Long
Dim lastColumn As Long
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).row
lastColumn = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' Set the range of the data in the source worksheet
Dim dataRange As Range
Set dataRange = wsSource.Range("A2", wsSource.Cells(lastRow, lastColumn))
' Loop through each cell in the data range
For Each cell In dataRange.Cells
' Check if the cell value contains "Target percent"
If InStr(1, cell.Value, "Target percent", vbTextCompare) > 0 Then
' Rename the cell with a formula
cell.Value = Evaluate("=LEFT(RIGHT(A1,10),4)") ' Modify the formula as needed
End If
Next cell
' Prompt the user to select the range to copy
On Error Resume Next
Set copyRange = Application.InputBox("Select the range to copy.", Type:=8)
On Error GoTo 0
' Verify if the user made a selection
If copyRange Is Nothing Then
MsgBox "No range selected. Operation canceled.", vbInformation
Exit Sub
End If
' Copy the selected range to the destination range
copyRange.Copy destRange
' Adjust the destination range for the next paste
Set destRange = destRange.Offset(0, copyRange.Columns.Count) ' Offset by the number of columns in the copied range
' Close the source workbook
wbSource.Save
wbSource.Close False
file = Dir
Loop
' Delete unwanted rows
Dim rowsToKeep As Range
Dim rowsToDelete As Range
Dim rng As Range
Dim row As Range
' Prompt the user to select the row(s) to keep
On Error Resume Next
Set rowsToKeep = Application.InputBox("Select the row(s) to keep.", Type:=8)
On Error GoTo 0
' Verify if the user made a selection
If rowsToKeep Is Nothing Then
MsgBox "No rows selected. Operation canceled.", vbInformation
Exit Sub
End If
' Set the range of rows to delete
Set rng = wsDest.Range("2:" & wsDest.Rows.Count)
' Loop through each row in the range
For Each row In rng.Rows
' Check if the row is not in the selected rows to keep
If Intersect(row, rowsToKeep) Is Nothing Then
' Add the row to the range of rows to delete
If rowsToDelete Is Nothing Then
Set rowsToDelete = row
Else
Set rowsToDelete = Union(rowsToDelete, row)
End If
End If
Next row
' Delete the selected rows and shift the remaining rows up
If Not rowsToDelete Is Nothing Then
rowsToDelete.Delete Shift:=xlUp
MsgBox "Selected rows deleted successfully.", vbInformation
Else
MsgBox "No rows to delete.", vbInformation
End If
End SubBackground: All files have matching questions and just below there are responses in column a and in column b there are values for those responses. This files are for different years. Below is sample format of data.
| Which, if any, supplements or particular meals do you have pre/post work out? Select all that apply. | |
| Response label | Target percent |
| Fruit | 100.00% |
| Eggs | 51.15% |
| Milk | 49.56% |
| Supplements/Vitamins | 43.64% |
| Salad | 30.92% |
| Protein Shakes | 36.98% |
| Peanut/ Almond Butter | 27.44% |
| Ice cream | 22.24% |
After every blank line, a new question starts in the same format. question in column a and its response values in column b. Problem here is that when data gets pasted order of this questions does not match. For eg: If we take above question and response values as example. After pasting this data from one file, second paste will be for some other question and likewise for other paste. I have attached sample of paste that this code does.
Please suggest if any improvement can be done in current code to maintain order or if we can use any available excel tools like sort etc.
Any new code achieving result is also welcome. Thanks for your time.
