I am comparing two sheets and their columns. My code runs. Problem is it compares most of the values and leaves some values though they are the same.
Sub Peformance()
Dim k As Integer
Dim i As Integer
Dim j As Integer
For i = 1 To 138
If (ActiveWorkbook.Worksheets("report").Cells(i, 6).Value = "course-1") Then
For j = 1 To 138
If (ActiveWorkbook.Worksheets("report").Cells(i, 1).Value = Cells(j, 1)) Then
Cells(j, 4).Value = (ActiveWorkbook.Worksheets("report").Cells(i, 12).Value) / 100
Cells(j, 5).Value = (ActiveWorkbook.Worksheets("report").Cells(i, 20).Value) / 100
Cells(j, 6).Value = (ActiveWorkbook.Worksheets("report").Cells(i, 13).Value)
End If
Next j
End If
Next i
For k = 1 To 138
If (IsEmpty(Cells(k, 4).Value)) Then
Cells(k, 4).Value = 0
Cells(k, 5).Value = 0
End If
If (IsEmpty(Cells(k, 6).Value)) Then
Cells(k, 6).Value = 0
End If
End Sub
In one file (sheet-2) I have students courses like course-1, course-2, course-3 etc.
In the other file (sheet-1) I have students names.
After comparing names (Column-1 of sheet-2 and sheet-1) I have to copy the performance from sheet-2 to sheet-1.
It runs but is not showing output for some students whose names are same.
Also how can I add the feature of case sensitive?
Sample Data
Sheet2:
Name
Email
External
Course
Course-ID
Course-Slug
Work-Percentage
A
a#gmail.com
12
A
course
course-1
63%
B
b#gmail.com
13
A
course
course-1
19%
Sheet1:
Name
Work-Percentage
A
B
So sheet1 column Work-Percentage will copy data from Work-Percentage column after comparing the name and course-Slug from sheet-2
Double For...Next
Adjust the name of the Destination Worksheet (dws) because I named it Course-1.
StrComp is taking care of the case-sensitivity issues.
This is just a quick fix for you to learn (understand). Otherwise, the efficiency can vastly be improved.
Not tested.
The Code
Option Explicit
Sub Peformance()
' Constants
Const sFirstRow As Long = 2
Const dFirstRow As Long = 2
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Report")
Dim sLastRow As Long: sLastRow = sws.Cells(sws.Rows.Count, 1).End(xlUp).Row
Dim k As Long
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Course-1")
Dim dLastRow As Long: dLastRow = dws.Cells(dws.Rows.Count, 1).End(xlUp).Row
Dim i As Long
' Loop
For i = dFirstRow To dLastRow
For k = sFirstRow To sLastRow
If StrComp(sws.Cells(k, 6).Value, "course-1", vbTextCompare) = 0 _
And StrComp(dws.Cells(i, 1).Value, sws.Cells(k, 1).Value, _
vbTextCompare) = 0 Then
' Student was found in Source Worksheet.
dws.Cells(i, 4).Value = sws.Cells(k, 12).Value / 100
dws.Cells(i, 5).Value = sws.Cells(k, 20).Value / 100
dws.Cells(i, 6).Value = sws.Cells(k, 13).Value
Exit For ' Student was found, no need to loop any longer.
End If
Next k
If k > sLastRow Then
' Student wasn't found in Source Worksheet.
If IsEmpty(dws.Cells(i, 4)) Then
If IsEmpty(dws.Cells(i, 6)) Then
dws.Cells(i, 4).Resize(3).Value = 0
Else
dws.Cells(i, 4).Resize(2).Value = 0
End If
End If
End If
Next i
End Sub
Related
I have the following macro which is so close to what I need. The issue I have is if the data is already in sheet2 it inserts a new line and the same data where as I don't want it duplicated. I have tried a few things but I cant quite get there
'start with sheet 1
Sheets(1).Activate
Dim rowStartSheet1, rowStartSheet2, lastRowSheet1, lastRowSheet2 As Integer
'change this variable if your row doesn't start on 2 as in this example for sheet1 and sheet2
rowStartSheet1 = 2
rowStartSheet2 = 2
'gets you the last row in sheet 1
lastRowSheet1 = Cells(Rows.Count, 1).End(xlUp).Row
'this entire for block is to check if a data row in sheet 1 is in sheet 2 and if so, copy and paste the rest of the data points
For i = rowStartSheet1 To lastRowSheet1
'case 1 where column C matches column A first time around (no duplicates)
'change this variable if sheet 2 starts on a different row
Sheets(2).Activate
lastRowSheet2 = Cells(Rows.Count, 1).End(xlUp).Row
'loops through sheet 2 column A to check if it matches what we want in sheet1 Column C
For ii = rowStartSheet2 To lastRowSheet2
'inputs if found first time around
If Sheets(1).Cells(i, 3) = Cells(ii, 1) And Cells(ii, 7) = "" Then
Cells(ii, 7) = Sheets(1).Cells(i, 1)
Cells(ii, 8) = Sheets(1).Cells(i, 2)
Exit For
'if sheet2 column G already has info in it, create a new row
ElseIf Sheets(1).Cells(i, 3) = Cells(ii, 1) And Cells(ii, 7) <> "" Then
Rows(ii).Select
Selection.Insert Shift:=xlShiftDown
Cells(ii, 1) = Sheets(1).Cells(i, 3)
Cells(ii, 7) = Sheets(1).Cells(i, 1)
Cells(ii, 8) = Sheets(1).Cells(i, 2)
Exit For
End If
Next ii
Next i
End Sub
All help appreciated
SHEET1
SHEET2
In my code below I refer to columns by their name (like "A", "B") instead of their number as you have done. This isn't intended as criticism. On the contrary, I much prefer to use numbers and usually declare them in enumerations. However, I felt that you might find my code more readable with the syntax I chose.
Sub CopyUniqueItems()
' 09 Aug 2017
Const RsFirst As Long = 2
Const RtFirst As Long = 2
Const Lot As Long = 1
Const Part As Long = 2
Const Col As Long = 3
Dim WsS As Worksheet ' S = Source
Dim WsT As Worksheet ' T = Target
Dim Rng As Range
Dim Itm As Variant
Dim Rs As Long, RsLast As Long ' Row / last row in WsS
Dim Rt As Variant, RtLast As Long ' Row / last row in WsT
Set WsS = Worksheets(1) ' { better to call by name
Set WsT = Worksheets(2) ' { like Worksheets("Sheet2")
RsLast = WsS.Cells(WsS.Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
For Rs = RsFirst To RsLast
With WsS
Itm = .Range(.Cells(Rs, "A"), .Cells(Rs, "C")).Value
End With
With WsT
RtLast = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Columns("A")
Set Rng = .Range(.Cells(RtFirst), .Cells(RtLast))
End With
On Error Resume Next
Rt = Application.Match(Itm(1, Lot), Rng, 0)
If IsError(Rt) Then
' not found
Rt = Application.Max(RtLast + 1, RtFirst)
Else
' exists already
Rt = Rt + RtFirst - 1
Do
If (.Cells(Rt, "G").Value = Itm(1, Part)) And _
(.Cells(Rt, "H").Value = Itm(1, Col)) Then
Rt = 0
Exit Do
Else
Rt = Rt + 1
End If
Loop While .Cells(Rt, "A").Value = Itm(1, Lot)
.Rows(Rt).Insert Shift:=xlShiftDown
End If
If Rt Then
.Cells(Rt, "A").Value = Itm(1, Lot)
.Cells(Rt, "G").Value = Itm(1, Part)
.Cells(Rt, "H").Value = Itm(1, Col)
End If
End With
Next Rs
Application.ScreenUpdating = True
End Sub
BTW, Dim rowStartSheet1, rowStartSheet2, lastRowSheet1, lastRowSheet2 As Integer declares only lastRowSheet2 as integer. All the others are undefined and therefore variants.
I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub
I've one workbook with 170K rows, I will delete all rows when the result between cells is 0,
For those operation, normally I use the code below, but with 170K (the rows will be deleted are 90K) the code run very slowly.
Someone know another way more performance.
Thank
Last = Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "K").Value + Cells(i, "L").Value) < 1 Then
Cells(i, "A").EntireRow.Delete
End If
Next i
As long as your fine putting the data on a new tab, the code below will do everything you need in 1.5 seconds.
Sub ExtractRows()
Dim vDataTable As Variant
Dim vNewDataTable As Variant
Dim vHeaders As Variant
Dim lastRow As Long
Dim i As Long, j As Long
Dim Counter1 As Long, Counter2 As Long
With Worksheets(1)
lastRow = .Cells(Rows.Count, "K").End(xlUp).row
vHeaders = .Range("A1:L1").Value2
vDataTable = .Range("A2:L" & lastRow).Value2
End With
For i = 1 To UBound(vDataTable)
If vDataTable(i, 11) + vDataTable(i, 12) > 0 Then
Counter1 = Counter1 + 1
End If
Next
ReDim vNewDataTable(1 To Counter1, 1 To 12)
For i = 1 To UBound(vDataTable)
If vDataTable(i, 11) + vDataTable(i, 12) > 0 Then
Counter2 = Counter2 + 1
For j = 1 To 12
vNewDataTable(Counter2, j) = vDataTable(i, j)
Next j
End If
Next
Worksheets.Add After:=Worksheets(1)
With Worksheets(2)
.Range("A1:L1") = vHeaders
.Range("A2:L" & Counter1 + 1) = vNewDataTable
End With
End Sub
Here, my approach for your problem according to rwilson's idea.
I already tested it. It very very reduce executing time. Try it.
Sub deleteRow()
Dim newSheet As Worksheet
Dim lastRow, newRow As Long
Dim sheetname As String
Dim startTime As Double
sheetname = "sheetname"
With Sheets(sheetname)
Set newSheet = ThisWorkbook.Worksheets.Add(After:=Sheets(.Name))
'Firstly copy header
newSheet.Rows(1).EntireRow.Value = .Rows(1).EntireRow.Value
lastRow = .Cells(.Rows.Count, "K").End(xlUp).row
newRow = 2
For row = 2 To lastRow Step 1
If (.Cells(row, "K").Value + .Cells(row, "L").Value) >= 1 Then
newSheet.Rows(newRow).EntireRow.Value = .Rows(row).EntireRow.Value
newRow = newRow + 1
End If
Next row
End With
Application.DisplayAlerts = False
Sheets(sheetname).Delete
Application.DisplayAlerts = True
newSheet.Name = sheetname
End Sub
Here is a non-VBA option you can try:
In column M compute the sum of columns K and L
Highlight column M and the click Find and select > Find
Type in 0 in the Find what box and also select values in the Look in box
Select Find all and in the box that shows the found items select all entires (click in the box and press CTRL + A)
On the ribbon select Delete and then Delete sheet rows
Now manually delete column M
I haven't tried this with 170k+ rows but maybe worth assessing performance versus the VBA loop.
thank at all for your ideas but the really fast code is: use an array tu populate whit the correct date and replare all table of the end sort the table:
Sub Macro13(control As IRibbonControl)
Dim avvio As Date
Dim arresto As Date
Dim tempo As Date
Application.ScreenUpdating = False
Application.Calculation = xlManual
avvio = Now()
Dim sh As Worksheet
Dim arng As Variant
Dim arrdb As Variant
Dim UR As Long, x As Long, y As Long
Dim MyCol As Integer
Set sh = Sheets("Rol_db")
MyCol = 1
sh.Select
UR = sh.Cells(Rows.Count, MyCol).End(xlUp).Row
ReDim arrdb(2 To UR, 1 To 12) As Variant
For x = 2 To UR
If Cells(x, 11) + Cells(x, 12) > 0 Then
For y = 1 To 12
arrdb(x, y) = Cells(x, y)
Next y
Else
For y = 1 To 12
arrdb(x, y) = ""
Next y
End If
Next x
sh.Range("A2:L" & UR) = arrdb
arresto = Now()
tempo = arresto - avvio
Debug.Print "Delete empty rows " & tempo
Range("A2:L" & UR).Sort key1:=Range("A2:L" & UR), _
order1:=xlAscending, Header:=xlNo
Range("A4").Select
ActiveWindow.FreezePanes = True
conclusioni:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
time for my sheet 170K 00:00:07.
as soon as I have a minute I feel a loop of the columns
I have a search function which works perfectly for searching for Exact Numerical values, However I need to adapt it so it searches for text within a cell and only extracts that text. For example it searches column 7. In column 7 there may be a cell containing the words Interface - HPT, SAS, LPT Ideally I would like to search for the word Interface - HPT then extract Only this text from the cell. I also need the search function to be able to do this for multiple different values. So for example run a search for Interface - HPT
Interface - SAS and Interface LPT separate from each other. Is this Possible ?
Here is the code I have at the moment:
Sub InterfaceMacro()
Dim Headers() As String: Headers = _
Split("Target FMECA,Part I.D,Line I.D,Part No.,Part Name,Failure Mode,Assumed System Effect,Assumed Engine Effect", ",")
Worksheets.Add().Name = "Interface"
Dim wsInt As Worksheet: Set wsInt = Sheets("Interface")
wsInt.Move after:=Worksheets(Worksheets.Count)
wsInt.Cells.Clear
Application.ScreenUpdating = False
With wsFHA
For i = 0 To UBound(Headers)
.Cells(2, i + 2) = Headers(i)
.Columns(i + 2).EntireColumn.AutoFit
Next i
.Cells(1, 2) = "Interface TABLE"
.Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).MergeCells = True
.Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 2), .Cells(2, UBound(Headers) + 2)).Font.Bold = True
End With
Dim SourceCell As Range, FirstAdr As String
Dim RowCounter As Long: RowCounter = 3
Dim SearchTarget() As String
SearchTarget = Split("9.1,18.0", ",")
For i = 0 To UBound(SearchTarget)
If Worksheets.Count > 1 Then
For j = 1 To Worksheets.Count - 1
With Sheets(j)
Set SourceCell = .Columns(7).Find(SearchTarget(i), LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
FirstAdr = SourceCell.Address
Do
wsInt.Cells(RowCounter, 2).Value = SearchTarget(i)
wsInt.Cells(RowCounter, 3).Value = .Cells(SourceCell.Row, 6).Value
wsInt.Cells(RowCounter, 4).Value = .Cells(3, 10).Value
wsInt.Cells(RowCounter, 5).Value = .Cells(2, 10).Value
wsInt.Cells(RowCounter, 6).Value = .Cells(SourceCell.Row, 2).Value
For k = 0 To SourceCell.Row - 1
If .Cells(SourceCell.Row - k, 3).Value <> "continued." Then
wsFHA.Cells(RowCounter, 7).Value = .Cells(SourceCell.Row - k, 3).Value
Exit For
End If
Next k
wsInt.Cells(RowCounter, 8).Value = .Cells(SourceCell.Row, 14).Value
Set SourceCell = .Columns(7).FindNext(SourceCell)
RowCounter = RowCounter + 1
Loop While Not SourceCell Is Nothing And SourceCell.Address <> FirstAdr
End If
End With
Next j
End If
Next i
End Sub
The part I believe needs editing is this section
Dim SourceCell As Range, FirstAdr As String
Dim RowCounter As Long: RowCounter = 3
Dim SearchTarget() As String
SearchTarget = Split("9.1,18.0", ",")
For i = 0 To UBound(SearchTarget)
If Worksheets.Count > 1 Then
For j = 1 To Worksheets.Count - 1
With Sheets(j)
Set SourceCell = .Columns(7).Find(SearchTarget(i), LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
FirstAdr = SourceCell.Address
You can define the array to search the same way as you define it for numbers.
To search also part of the cell content you need to change .Find(SearchTarget(i), LookAt:=xlWhole) to .Find(SearchTarget(i), LookAt:=xlPart).
VBA looks in formulas / results the same way as it works in Find / Replace dialog. (set .LookIn to either xlValues or xlFormulas)
I've been trying to piece this together but have been unsuccessful so far.
Workbook2, with sheet name "Sheet1" has the data which needs to be pulled into Workbook1, with sheet name "DATA".
Workbook 2:
Student ID Date completed Question# Score
101 12/10/2018 1 0
101 12/10/2018 2 5
101 12/10/2018 3 10
101 12/10/2018 4 0
102 12/05/2018 1 10
102 12/05/2018 2 0
Workbook 1:
Student ID Date Completed Question1 2 3 4
101 12/10/2018 0 5 10 0
102 12/05/2018 10 0
What I'm trying to do is get the code to loop through the column with the Question # (in "Sheet1" Workbook 2), and if the student numbers match, and if the question number in Workbook 2 matches the column heading in Sheet "DATA" (Workbook 1) then return the student number, date completed and most importantly, the score value under the matching column heading.
The code I've been trying to use is below. Any suggestions would be welcome:
Public Sub grabqdata()
Dim wbmacro As Workbook
Dim wblean As Workbook
Set wbmacro = Workbooks.Item("MacroFile.xlsm")
Set wblean = Workbooks.Item("Workbook2.xlsx")
Dim wsmacro As Worksheet
Dim wslean As Worksheet
Set wsmacro = wbmacro.Worksheets.Item("Data")
Set wslean = wblean.Worksheets.Item("Sheet1")
Dim leanrange As Range
Set leanrange = wslean.Range("A2:A150000")
Dim headerrange As Range
Set headerrange = wsmacro.Range("A1:G1")
Dim qrange As Range
Set qrange = wslean.Range("D2:D150000")
Dim macrorange As Range
Set macrorange = wsmacro.Range("A:A")
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim colm As Long
colm = WorksheetFunction.Match(wsmacro, Range("A1:G1"), 0)
Dim cell As Range
i = 1
For Each cell In leanrange
If leanrange.Range("A2") = macrorange.Range("a2") Then
wsmacro.Range("C2").Offset(i, 0) = wslean.Range("D2").Offset(i, 0)
i = i + 1
End If
Next cell
End Sub
Column C is where the first Q# is (so Q1 or "1").
Thank you!
Not the prettiest, but this should get the job done... This also makes some assumptions, like there aren't multiple completed dates for the same student ID (needed clarification) - also assumes that every student goes through the same question #s (1, 2, 3, etc.).
Option Explicit
Sub Test()
Dim sht As Worksheet, sht2 As Worksheet
Dim i As Long, k As Long
Dim lastrow As Long, lastcol, foundrow As Long, foundcol As Long
Set sht = Workbooks("Testfile1.xlsm").Worksheets("Sheet1")
Set sht2 = Workbooks("Testfile2.xlsm").Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
sht2.Cells.ClearContents
sht2.Cells(1, 1).Value = "Student ID"
sht2.Cells(1, 2).Value = "Date completed"
sht2.Cells(1, 3).Value = "Question # 1"
k = 2
For i = 2 To lastrow
If Application.CountIf(sht2.Range("A:A"), sht.Cells(i, 1).Value) = 0 Then
sht2.Cells(k, 1).Value = sht.Cells(i, 1).Value
sht2.Cells(k, 2).Value = sht.Cells(i, 2).Value
lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column
sht2.Cells(k, 3).Value = sht.Cells(i, 4).Value
k = k + 1
Else
foundrow = sht2.Range("A:A").Find(What:=sht.Cells(i, 1).Value).Row
On Error Resume Next
foundcol = sht2.Range("1:1").Find(What:="Question # " & sht.Cells(i, 3).Value).Column
On Error GoTo 0
If foundcol = 0 Then
lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column
sht2.Cells(1, lastcol + 1).Value = "Question # " & sht.Cells(i, 3).Value
sht2.Cells(foundrow, lastcol + 1).Value = sht.Cells(i, 4).Value
Else
sht2.Cells(foundrow, foundcol).Value = sht.Cells(i, 4).Value
End If
End If
Next i
End Sub