I am trying to build an Excel workbook that takes data from one sheet, and fills out another based on a system name. I am having a problem with the first for next loop. It works for the first system, but if there are more than one item in the system it just stops working. The second for each loop works great. Is there a better way to run my first loop. I try an if the first For each variable matches the second for each then increment, but the code says the next Inspectcell does not have a for each. The system name is always in column C and starts at C7
Sub fillthereport()
Dim xx As Variant, ws As Variant, yy As Variant
Dim ws2 As Variant, xxx As Variant, yyy As Variant
Dim rowed As Integer, b As Integer
'Dim MySht As Worksheet
Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single
Dim conv As Variant
Dim item As Variant
Dim picnum As Variant
Dim mergecells As String, mergecells2 As String, mergecolor As String
Dim horstart As Variant, horend As Variant
Dim verstart As Variant, verend As Variant
Dim Inspectcell As Range, reportcell As Range
'worksheets loop operator
ws = 1
'worksheets loop operator to
ws2 = 6
'row designator from
xx = 7
'column designator from
yy = 3
'row designator to
xxx = 68
'column designator to
yyy = 37
'This is not the variable you are looking for
b = 0
'These are the variables you are looking for
yel = 0
bl = 0
re = 0
Folderpath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
reportcell = Worksheets("inspection Data").Range("C7")
'make extra sheets in the report to be filled
For Each Inspectcell In Worksheets("inspection Data").Range("C7:C18")
If Inspectcell = reportcell Then
Worksheets(ws2).Select
Worksheets(ws2).Range("A60:AY114").Select
Selection.Copy
Sheets(ws2).Range("A115:AY169").Select
ActiveSheet.Paste
Sheets(ws2).Range("A170:AY224").Select
ActiveSheet.Paste
'reportcell = Inspectcell
For Each reportcell In Worksheets("inspection Data").Range("C7:C18")
If reportcell = Inspectcell Then
'(This is about 110 lines of code that work great)
xx = xx + 1
b = b + 1
'worksheets loop operator
'ws = ws + 1
'worksheets loop operator to
'ws2 = ws2 + 1
'column designator from
'yy = yy + 1
'row designator to
If Not b Mod 3 = 0 Then
xxx = xxx + 16
Else
xxx = xxx + 23
End If
Else 'If xx = 15 Then
Exit For
End If
'xxx = xxx + 22
Next reportcell
ws2 = ws2 + 1
'Else
'Exit for
End if
Next Inspectcell
Related
I would like to pick random names from columns in excel like this :
-In the first sheet "Inscrp" is where the lists are, and the second sheet "Tirage" is where the results of the picking.
-Column A in the sheet "Tirage" should pick random names from column A in the sheet "Inscrp" and the same for the column B, C , till the number of columns I chose
I managed to do this with only the first column and here is the code :
Sub PickNamesAtRandom()
Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes
Application.ScreenUpdating = False
HowMany = 5
CellsOut = 8
ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Worksheets("Inscrp").Range("A3:A100")) - 1 ' Find how many names in the list
i = 1
Do While i <= HowMany
RandomNo:
RandomNumber = Application.RandBetween(3, NoOfNames + 1)
'Check to see if the name has already been picked
For ArI = LBound(Names) To UBound(Names)
If Names(ArI) = Worksheets("Inscrp").Cells(RandomNumber, 1).Value Then
GoTo RandomNo
End If
Next ArI
Names(i) = Worksheets("Inscrp").Cells(RandomNumber, 1).Value ' Assign random name to the array
i = i + 1
Loop
'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)
Worksheets("Tirage").Cells(CellsOut, 1) = Names(ArI)
CellsOut = CellsOut + 1
Next ArI
Application.ScreenUpdating = True
End Sub
Please, test the next code. If I correctly understand your nee, it will extract HowMany random numbers from each column (nrCol) of "Inscrip" sheet and placed starting from CellsOut in sheet "Tirage". The already extracted name is eliminated from the array where it used to exist (to avoid repeated names). The ranges ar placed in arrays and due to that, the code should be very fast mostly working in memory, even for large ranges:
Sub PickNamesAtRandom()
Dim shI As Worksheet, lastR As Long, shT As Worksheet, HowMany As Long
Dim rndNumber As Integer, Names() As String, i As Long, CellsOut As Long
HowMany = 5: CellsOut = 8
Set shI = Worksheets("Inscrp")
Set shT = Worksheets("Tirage")
Dim col As Long, arrCol, filt As String, nrCol As Long
nrCol = 2 'number of columns to be returned. It can be changed and also be calculated...
For col = 1 To nrCol
lastR = shI.cells(shI.rows.count, col).End(xlUp).Row 'last row in column to be processed
If lastR >= HowMany + 2 Then '+ 2 because the range is build starting with the third row...
arrCol = Application.Transpose(shI.Range(shI.cells(3, col), shI.cells(lastR, col)).Value2) 'place the range in a 1D array
ReDim Names(1 To HowMany) 'Set the array size to how many names required
For i = 1 To UBound(Names)
tryAgain:
Randomize
rndNumber = Int((UBound(arrCol) - LBound(arrCol) + 1) * Rnd + LBound(arrCol))
If arrCol(rndNumber) = "" Then GoTo tryAgain
Names(i) = arrCol(rndNumber)
filt = arrCol(rndNumber) & "##$$#": arrCol(rndNumber) = filt
arrCol = filter(arrCol, filt, False) 'eliminate the already used name from the array
Next i
shT.cells(CellsOut, col).Resize(UBound(Names), 1).Value2 = Application.Transpose(Names)
End If
Next col
MsgBox "Ready..."
End Sub
If something unclear, do not hesitate to ask for clarifications...
I am trying to sort through a couple hundred rows in a workbook to pull information based on progressive keys. First, create a list of all unique names, then for each unique name find all associated product codes, and finally create a list of each quantity of product. What it should look like:
'Name1
'-----product1
'-------------quantity1
'-------------quantity2
'-----product2
'-------------quantity1
'-------------quantity2
'name2
'-----product1
'-------------quantity1
'-------------quantity2
'-----product2
'-------------quantity1
'-------------quantity2
I tried using a dictionary but can't figure out how to get it to return more than the first entry per unique name. This is the code I have so far:
Sub CreateNameList2()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("Label-Mod Data")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim AssociateName As String
Dim ColAssociateNames As Integer
Dim ColCurrentLabels As Integer
Dim ColPTSCodes As Integer
Dim ColRegionCodes As Integer
Dim nbRows As Long
Dim iRow As Integer
Dim i As Integer
Dim k As Variant
ColAssociateNames = 8
ColCurrentLabels = 9
ColPTSCodes = 14
ColRegionCodes = 15
nbRows = 155
i = 2
For iRow = 2 To nbRows
AssociateName = sws.Cells(iRow, ColAssociateNames).Value2
If Not dict.Exists(AssociateName) Then
dict.Add Key:=AssociateName, Item:=Array(sws.Cells(i, ColPTSCodes).Value2, sws.Cells(i, ColCurrentLabels).Value2, sws.Cells(i, ColRegionCodes).Value2)
i = i + 1
End If
Next iRow
iRow = 2
For Each k In dict.Keys
With sws
.Cells(iRow, 18).Value2 = k
.Cells(iRow, 19).Value2 = dict.Item(k)(0)
.Cells(iRow, 20).Value2 = dict.Item(k)(1)
.Cells(iRow, 21).Value2 = dict.Item(k)(2)
End With
iRow = iRow + 1
Next k
Set dict = Nothing
Debug.Print
Application.ScreenUpdating = True
End Sub
Can this be done with a dictionary?
For privacy reasons I can't show the data but I will try to explain it.
My raw data comes in 3 columns and varies in number of rows, todays is 155. Column 1 has a name, column 2 has a product ID and column 3 has a quantity. There are currently 48 possible names, 12 possible product ID's and undetermined quantity amounts. Looks Like this:
Name1 | product 3 | 25
Name1 | product 1 | 12
Name5 | product 9 | 171
Name4 | product 3 | 48
Name1 | product 7 | 23
Name42 | product 9 | 9
Name5 | product 1 | 22
Name4 | product 3 | 42
What I need to do is change it to:
Name1 | product 1 | 12
| product 3 | 25
| product 7 | 23
Name4 | product 3 | 90
(combine above quantity with matching name and product)
Name5 | product 1 | 22
| product 9 | 171
Name42 | product 9 | 9
Like this would work:
Sub Tester()
Dim dict As Object, rw As Range, Q, kN, kP
Set dict = CreateObject("scripting.dictionary")
Set rw = Range("A1:C1") 'first row of data
Do While Application.CountA(rw) = 3 'while row data is complete
kN = rw.Cells(1).Value 'name key
kP = rw.Cells(2).Value 'product key
Q = rw.Cells(3).Value 'quantity
'add keys if missing...
If Not dict.exists(kN) Then dict.Add kN, CreateObject("scripting.dictionary")
If Not dict(kN).exists(kP) Then dict(kN).Add kP, 0
dict(kN)(kP) = dict(kN)(kP) + Q 'sum quantity for this key combination
Set rw = rw.Offset(1) 'next row
Loop
'output to Immediate pane
For Each kN In dict
Debug.Print "---" & kN & "---"
For Each kP In dict(kN)
Debug.Print " " & kP & " = " & dict(kN)(kP)
Next
Next kN
End Sub
Based on the additional information provided, it looks like you can make use of a composite key comprised of the Name and Product identifiers. Doing so can support a solution that uses an AssociateName-to-nameProductQuantityMap Dictionary where nameProductQuantityMap is also a Dictionary that associates Quantity totals to each Name + Product composite key.
Option Explicit
'May need a more elaborate delimiter if "." used in the Names or Products
Const compositeKeyDelimiter As String = "."
Private Type TColumns
Associate As Long
Name As Long
Product As Long
Quantity As Long
End Type
Sub CreateNameList2Answer()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("Label-Mod Data")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim AssociateName As String
Dim ColAssociateNames As Integer
Dim ColCurrentLabels As Integer
Dim ColPTSCodes As Integer
Dim ColRegionCodes As Integer
Dim nbRows As Long
Dim iRow As Integer
Dim i As Integer
ColAssociateNames = 8
ColCurrentLabels = 9
ColPTSCodes = 14
ColRegionCodes = 15
nbRows = 155
i = 2
'Modify if these are not mapped to the correct column names
Dim xColumns As TColumns
xColumns.Associate = ColAssociateNames
xColumns.Name = ColCurrentLabels
xColumns.Product = ColPTSCodes
xColumns.Quantity = ColRegionCodes
Dim xAssociateName As Variant
Dim xName As String
Dim xProduct As String
Dim xQuantity As Long
Dim xCompositeKey As String
Dim nameProductQuantityMap As Object
For iRow = 2 To nbRows
AssociateName = sws.Cells(iRow, xColumns.Associate).Value2
xName = sws.Cells(i, xColumns.Name).Value2
xProduct = sws.Cells(i, xColumns.Product).Value2
xQuantity = CLng(sws.Cells(i, xColumns.Quantity).Value2)
xCompositeKey = CreateCompositeKey(xName, xProduct)
If Not dict.Exists(AssociateName) Then
dict.Add Key:=AssociateName, Item:=CreateObject("Scripting.Dictionary")
End If
Set nameProductQuantityMap = dict.Item(AssociateName)
If Not nameProductQuantityMap.Exists(xCompositeKey) Then
nameProductQuantityMap.Add xCompositeKey, 0
End If
nameProductQuantityMap.Item(xCompositeKey) _
= nameProductQuantityMap.Item(xCompositeKey) + xQuantity
i = i + 1
Next iRow
iRow = 2
Dim xKey As Variant
For Each xAssociateName In dict.Keys
Set nameProductQuantityMap = dict.Item(xAssociateName)
For Each xKey In nameProductQuantityMap
LoadContent sws, iRow, CStr(xAssociateName), _
CStr(xKey), _
nameProductQuantityMap.Item(xKey)
iRow = iRow + 1
Next
Next xAssociateName
Set dict = Nothing
Set nameProductQuantityMap = Nothing
Debug.Print
Application.ScreenUpdating = True
End Sub
Private Sub LoadContent(ByVal pWksht As Worksheet, ByVal pRow As Long, _
ByVal pAssociate As String, _
ByVal pCompositeKey As String, _
ByVal pQuantity As Long)
Dim xName As String
Dim xProduct As String
ExtractNameAndProductFromKey pCompositeKey, xName, xProduct
With pWksht
.Cells(pRow, 18).Value2 = pAssociate
.Cells(pRow, 19).Value2 = xName
.Cells(pRow, 20).Value2 = xProduct
.Cells(pRow, 21).Value2 = pQuantity
End With
End Sub
Private Function CreateCompositeKey(ByVal pName As String, ByVal pProduct As String) As String
CreateCompositeKey = pName & compositeKeyDelimiter & pProduct
End Function
Private Sub ExtractNameAndProductFromKey(ByVal pCompositeKey As String, ByRef pOutName As String, ByRef pOutProduct As String)
Dim xKeyParts As Variant
xKeyParts = Split(pCompositeKey, compositeKeyDelimiter)
pOutName = xKeyParts(0)
pOutProduct = xKeyParts(1)
End Sub
Screenshot#1
So i have to replace positive & negative numbers in column "A", from sheet "1" to sheet second[positive] and third sheet[negative].
Here is what i tried:
Sub Verify()
Dim row As Long
For row = 1 To 20
If ActiveSheet.Cells(row,1) <> "" Then
If ActiveSheet.Cells(row,1) > 0 Then
ActiveSheet.Cells(row,2) = ActiveSheet.Cells(row,1)
End If
End If
Next
End Sub
Here is what that program do:
Screenshot#2
So as we see i am getting positive values in column "B" sheet 1.
Your code is not currently working because you are only using ActiveSheet, rather than placing data on other worksheets as required. Below is some VBA code that loops column A in your original sheet, and outputs the data to column A in two different sheets as required:
Sub sSplitPositiveNegative()
Dim wsOriginal As Worksheet
Dim wsPositive As Worksheet
Dim wsNegative As Worksheet
Dim lngLastRow As Long
Dim lngPositiveRow As Long
Dim lngNegativeRow As Long
Dim lngLoop1 As Long
Set wsOriginal = ThisWorkbook.Worksheets("Original")
Set wsPositive = ThisWorkbook.Worksheets("Positive")
Set wsNegative = ThisWorkbook.Worksheets("Negative")
lngLastRow = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
lngNegativeRow = 2
lngPositiveRow = 2
For lngLoop1 = 1 To lngLastRow
If wsOriginal.Cells(lngLoop1, 1).Value > 0 Then
wsPositive.Cells(lngPositiveRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngPositiveRow = lngPositiveRow + 1
Else
wsNegative.Cells(lngNegativeRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngNegativeRow = lngNegativeRow + 1
End If
Next lngLoop1
Set wsPositive = Nothing
Set wsNegative = Nothing
Set wsOriginal = Nothing
End Sub
You will need to change the names of the worksheets referenced in the code to match those in your workbook.
Regards
Made the code a little reusable for you. Feel free to change sheet names or the last_row variable. The last_pos_val and last_neg_val are used so you won't have empty rows on the second and third sheet. You didn't specify what to do with zero, so it's currently added to the negative sheet.
Sub Verify()
Dim row As Long, last_row As Long, last_pos_val As Long, last_neg_val As Long
Dim ws_source As Worksheet, ws_pos As Worksheet, ws_neg As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws_source = wb.Sheets("Sheet1")
Set ws_pos = wb.Sheets("Sheet2")
Set ws_neg = wb.Sheets("Sheet3")
last_pos_val = 1
last_neg_val = 1
last_row = 20
For row = 1 To last_row
If ws_source.Cells(row,1) <> "" Then
If ws_source.Cells(row,1) > 0 Then
ws_pos.Cells(last_pos_val,1) = ws_source.Cells(row,1)
last_pos_val = last_pos_val + 1
Else
ws_neg.Cells(last_neg_val,1) = ws_source.Cells(row,1)
last_neg_val = last_neg_val + 1
End If
End If
Next
End Sub
Split Positive & Negative
Adjust the values in the constants section.
Both subs are needed. The first sub calls the second one.
The Code
Option Explicit
Sub SplitPN()
Const Source As String = "Sheet1"
Const Positive As String = "Sheet2"
Const Negative As String = "Sheet3"
Const FirstRow As Long = 1
Const SourceColumn As Long = 1
Const PositiveFirstCell As String = "A1"
Const NegativeFirstCell As String = "A1"
Dim rngSource As Range
Dim rngPositive As Range
Dim rngNegative As Range
With ThisWorkbook
With .Worksheets(Source)
Set rngSource = .Columns(SourceColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rngSource Is Nothing Then Exit Sub
If rngSource.Row < FirstRow Then Exit Sub
Set rngSource = .Range(.Cells(FirstRow, SourceColumn), rngSource)
End With
Set rngPositive = .Worksheets(Positive).Range(PositiveFirstCell)
Set rngNegative = .Worksheets(Negative).Range(NegativeFirstCell)
End With
SplitPosNeg rngSource, rngPositive, rngNegative
End Sub
Sub SplitPosNeg(SourceRange As Range, PositiveFirstCell As Range, _
NegativeFirstCell As Range)
Dim Source, Positive, Negative
Dim UB As Long, i As Long
Source = SourceRange
UB = UBound(Source)
ReDim Positive(1 To UB, 1 To 1)
ReDim Negative(1 To UB, 1 To 1)
For i = 1 To UBound(Source)
Select Case Source(i, 1)
Case Is > 0: Positive(i, 1) = Source(i, 1)
Case Is < 0: Negative(i, 1) = Source(i, 1)
End Select
Next
PositiveFirstCell.Resize(UB) = Positive
NegativeFirstCell.Resize(UB) = Negative
End Sub
I have written the following code for the fourth worksheet where the number of rows and columns can increase based on the table dimension created in worksheet 1. Here's the code:
Dim sh1 As Worksheet
Set sh1 = Worksheets("Sheet 1")
Dim sh4 As Worksheet
Set sh4 = Worksheets("Sheet 4")
Dim operations As Integer
operations = sh1.Range("D4").Value
Dim contaminants As Integer
contaminants = sh1.Range("D6").Value
Dim firstRow As Integer
firstRow = sh4.Range("B10").Row
Dim operation As Integer
Dim lastRow As Integer
lastRow = firstRow + operations*contaminants - contaminants - operation
Dim b As Integer
b = 0
Dim c As Integer
c = 0
While c <= contaminants - 2
If sh4.Cells(10+b,3+c) = "Count" Then
sh4.Cells(10+b,3+c) = Application.WorksheetFunction.Sum(sh4.Range(sh4.Cells(firstRow, (3+c)), sh4.Cells(lastRow, (3+c))))
Else
b = b + 1
End If
c = c + 1
Wend
The code will do just the part of introducing the sum of defined range whenever it founds in column C the word "Count". Then it prints the value into column D, and advance into column E and so on until reaching contaminants - 2. Basically, I just want to print the result into D16 and E16 and I am not understanding what's wrong with: sh4.Cells(10+b,3+c) = Application.WorksheetFunction.Sum(sh4.Range(sh4.Cells(firstRow, (3+c)), sh4.Cells(lastRow, (3+c))))
C D E
10 1 0 -
11 2 - 1
12 3 1 -
13 4 - 1
14 5 1 -
15 6 - 1
16 Count 2 3
Thank you for your time!
Assumptions made are explained, integers replaced with longs, "Count" row number set in a variable, loop replaced with a for loop.
Dim sh1 As Worksheet
Set sh1 = Worksheets("Sheet 1")
Dim sh4 As Worksheet
Set sh4 = Worksheets("Sheet 4")
Dim operations As Long
operations = sh1.Range("D4").Value
Dim contaminants As Long
contaminants = sh1.Range("D6").Value
Dim firstRow As Long
firstRow = sh4.Range("B10").Row
Dim operation As Long
Dim lastRow As Long
lastRow = firstRow + operations * contaminants - contaminants - operation
Dim CountRow As Long
Dim lng As Long
'Assuming column 3 onwards has "count" and it always exists on the same row
CountRow = Application.Match("Count", sh4.Columns(3), 0)
'Start at column 4, assuming we don't want to overwrite "Count" in column C
For lng = 4 To contaminants - 2
sh4.Cells(CountRow, lng) = Application.WorksheetFunction.Sum(sh4.Range(sh4.Cells(firstRow, lng), sh4.Cells(lastRow, lng)))
Next lng
I have a table
Name ID Salary Educ Exp Salary Educ Exp
Mike 1 100 5 12 200 12 23
Peter 2 200 6 12 300 3 32
Lily 3 150 3 13 200 5 2
...................
I need to transform this table into
Name ID Salary Educ Exp
Mike 1 100 5 12
Peter 2 200 6 12
Lily 3 150 3 13
Mike 1 200 12 23
Peter 2 300 3 32
Lily 3 200 5 2
..................
How can I do this using VBA ?
Here is what I tried so far
Sub test()
Dim rg1 As Range, rg2 As Range, rg3 As Range, shtDest As Worksheet
Dim lLoop As Long, lRowDest As Long
Set rg1 = Selection.Areas(1)
Set rg2 = Selection.Areas(2)
Set rg3 = Selection.Areas(3)
Set shtDest = Worksheets.Add
lRowDest = 1
For lLoop = 1 To rg1.Rows.Count
lRowDest = lRowDest + rg2.Rows.Count + rg3.Rows.Count
Next
End Sub
After looking at the comments, this will move N sets of data into a single set of columns. This assumes that each row contains data for one Name/ID combination, as in your example.
Sub moveData()
Dim x As Range
Dim data As Range
Dim i As Long
Dim origId As Range
Dim id As Range
Dim idColCount As Long
Dim setCount As Long
Dim setCol As Long
Dim headerRange As Range
Set headerRange = Range("1:1")
Set id = Range(Range("A2"), Range("B2").End(xlDown))
Set origId = id
idColCount = id.Columns.Count
setCount = Application.WorksheetFunction.CountIfs(headerRange, "salary")
setCol = 1
For i = 1 To setCount
With headerRange
Set x = .Find("Salary", .Cells(1, setCol))
Set data = x.Offset(1).Resize(x.End(xlDown).Row - x.Row, 3)
data.Copy
id.Cells(1, 1).Offset(id.rows.Count, idColCount).PasteSpecial xlPasteAll
origId.Copy
id.Cells(1, 1).Offset(id.rows.Count).PasteSpecial xlPasteAll
Set id = Range(id, id.End(xlDown))
End With
setCol = x.Column
Next i
setCol = 1
With headerRange
Set x = .Find("Salary", .Cells(1, setCol))
setCol = x.Column
Set x = .Find("Salary", .Cells(1, setCol))
End With
Range(x, x.End(xlToRight).End(xlDown)).Clear
End Sub
See if this works for you, it loops through each row finding each Salary/Educ/Exp entry until it doesn't find another, moving each one to the bottom with the corresponding Name/ID and cleans up everything nicely for you.
Private Sub SplitTable()
Dim rng As Range '' range we want to iterate through
Dim c As Range '' iterator object
Dim cc As Range '' check cell
Dim lc As Range '' last cell
Dim ws As Worksheet
Dim keepLooking As Boolean '' loop object
Dim firstTime As Boolean
Dim offset As Integer
Dim Name As String, ID As Integer, Salary As Integer, Educ As Integer, Exp As Integer
Set ws = ActiveSheet '' adjust this to the sheet you want or leave it as ActiveSheet
Set rng = ws.Range("A2", "A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For Each c In rng
firstTime = True '' reset to true so we get an offset of five for the first entry
keepLooking = True
While keepLooking
If firstTime Then
Set cc = c.offset(, 5)
Else: Set cc = cc.offset(, 3)
End If
If cc <> "" Then '' if the salary has data in it, then grab what we expect to be Salaray/Educ/Exp
Name = c.Value
ID = c.offset(, 1).Value
Salary = cc.Value
Educ = cc.offset(, 1).Value
Exp = cc.offset(, 2).Value
'' Cleanup
cc.ClearContents
cc.offset(, 1).ClearContents
cc.offset(, 2).ClearContents
'' Move it to the bottom of columns A:E
Set lc = ws.Range("A" & ws.Rows.Count).End(xlUp).offset(1, 0)
lc.Value = Name
lc.offset(, 1).Value = ID
lc.offset(, 2).Value = Salary
lc.offset(, 3).Value = Educ
lc.offset(, 4).Value = Exp
Else: keepLooking = False
End If
firstTime = False '' set to false so we only get an offset of 3 from here on out
Wend
Next c
ws.Range("F1", ws.Range("A1").End(xlToRight)).ClearContents
End Sub