I have USER_ID, EVENT_ID and DATE and I need to check which of the events are real.
Real event is the first one by each user and every one which is at least 10 days after the last real event.
What i do is to order them by USER_ID and date and using this forumla =IF(A2<>A1;1;IF(C2-C1>=10;1;0)) but that way it calculates date diff between current and the previous event, not to the last real event.
Like if i have events at 01 05 and 13 from one user it will give me 1, 0, 0 but i need to compare to the last real event which is at 01 and it should give me 1, 0 ,1.
How can i do that.
| USER ID | EVENT ID | DATE | What I get | What I should get |
|:---------|:---------:|:------------:| :------------:|:------------: |
| 1 | 4 | 01.01.2020 | 1 | 1 |
| 1 | 5 | 05.01.2020 | 0 | 0 |
| 1 | 6 | 13.01.2020 | 0 | 1 |
| 2 | 7 | 03.01.2020 | 1 | 1 |
| 2 | 8 | 05.01.2020 | 0 | 0 |
| 2 | 9 | 06.01.2020 | 0 | 0 |
The number of events by user is not fixed.
Table
Here's a solution in VBA.
Sub Button1_Click()
'data
Cells.Clear
[a2:b7] = [{1,1;1,5;1,13;2,3;2,5;2,6}]
'code
lre = [b2]
For i = 2 To 7
If Cells(i, 1) <> Cells(i - 1, 1) Then
Cells(i, 3) = 1
ElseIf Cells(i, 2) - lre >= 10 Then
Cells(i, 3) = 1
lre = Cells(i, 2)
Else
Cells(i, 3) = 0
End If
Next i
End Sub
It uses the same logic as your formula, but uses the lre variable to store the last real event's date.
Related
Can you please advise how I can fix the following codes so that they do not class with each anymore. I apologise that I had to put down a lot of codes here but I really have no idea which of those are making them clash with each other.
So, I have this part to return "Rollup" for any empty Sales and Production cells if "Shipped" in Column AU (47th column).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim counter As Long
Dim lastcolumn As Long
lastColumn = Me.Cells(1, Me.Columns.Count).End(xlToLeft).Column
'Shipped without Title Transfer
If Me.Cells(1, Target.Column).Value = "MB51 Shipped" Then
For counter = 1 To lastColumn
If (Me.Cells(1, counter).Value = "Sales" Or Me.Cells(1, counter).Value = "Production") _
And IsEmpty(Me.Cells(Target.Row, counter).Value) Then
Me.Cells(Target.Row, counter).Value = "Rollup"
End If
Next counter
End If
Then I have this piece to return "x" in column AX (50th column) if the last Sales column has "Title Transfer".
Dim r As Range, r1 As Range, counter As Long
Dim MaxCol As Variant, rg As Range, j As Long
If Not Intersect(Target, Range("N:AP")) Is Nothing And Target.Column Mod 4 = 2 Then
Set r = Intersect(Target, Cells(1, 1).CurrentRegion, Columns(Target.Column).Resize(, 3))
Call DoCells(r)
End If
'Automatically put "x" if Title Transfer in any Sales columns
If Not Intersect(Target, Range("N:AP")) Is Nothing And Target.Column Mod 4 = 2 Then
If Target.CountLarge > 1 Then Exit Sub
Set rg = Range("N" & Target.Row & ":AP" & Target.Row)
MaxCol = 0
For j = Columns("AP").Column To Columns("N").Column Step -4
If Cells(Target.Row, j) <> "" Then
If j > MaxCol Then MaxCol = j
End If
Next
If MaxCol Mod 4 = 2 Then
If Cells(Target.Row, MaxCol).Value = "Title Transfer" Then
Cells(Target.Row, 50).Value = "x"
Else
Cells(Target.Row, 50).Value = ""
End If
End If
End If
'This I have 8 Sales Column, however, I only put 1 line down for demonstration
Set r = Intersect(Target, Cells(1, 1).CurrentRegion, Columns(colSales1).Resize(, 3))
If Not r Is Nothing Then Call DoCells(r)
If Not Intersect(Target, Range("N:AP")) Is Nothing And Target.Column Mod 4 = 2 Then
If Target.CountLarge > 1 Then Exit Sub
Set rg = Range("N" & Target.Row & ":AP" & Target.Row)
MaxCol = Evaluate("=MAX(IF(" & rg.Address & "<>"""",COLUMN(" & rg.Address & ")))")
If MaxCol Mod 4 = 2 Then
If Cells(Target.Row, MaxCol).Value = "Title Transfer" Then
Cells(Target.Row, 50).Value = "x"
Else
Cells(Target.Row, 50).Value = ""
End If
End If
End If
End Sub
Here is the DoCells sub that one of the lines calls up.
Private Sub DoCells(r As Range)
Dim r1 As Range
For Each r1 In r.Cells
With r1
Select Case .Column
Case colSales1, colSales2, colSales3, colSales4, colSales5, colSales6, colSales7, colSales8
Call MasterChange(.Resize(1, 3))
Case colProduction1, colProduction2, colProduction3, colProduction4, colProduction5, colProduction6, colProduction7, colProduction8
Call MasterChange(.Offset(0, -1).Resize(1, 3))
Case colDay1, colDay2, colDay3, colDay4, colDay5, colDay6, colDay7, colDay8
Call MasterChange(.Offset(0, -2).Resize(1, 3))
End Select
End With
Next
End Sub
Here is my data structure using Markdown Table:
| Title | Engine Family | Market Segment | Customer | Engine Model | S/N | Build Spec | ACTL.FINISH | Sales Order | Item | Committed Date | EPS Date | Target | Sales | Production | Day 1 | Status | Sales | Production | Day 2 | Status | Sales | Production | Day 3 | Status | Sales | Production | Day 4 | Status | Sales | Production | Day 5 | Status | Sales | Production | Day 6 | Status | Sales | Production | Day 7 | Status | Sales | Production | Day 8 | Status | Comments | MB51 Shipped | FPS? | Plant | Title Transfer |
|--------|---------------|----------------|----------|--------------|-----|------------|-------------|-------------|------|----------------|------------|--------|-------|------------|-------|--------|----------------|------------|----------------|--------|---------|------------|---------|------------------|---------|------------|---------|------------------|---------|------------|---------|------------------|---------|------------|---------|------------------|---------|------------|---------|------------------|---------|------------|---------|------------------|----------|--------------|------|-------|----------------|
| Rollup | PS | APU | ABC | 46C12 | 1 | BS1 | 0000-00-00 | 101 | 450 | 2019-12-31 | 2019-12-31 | Rollup | Green | Rollup | Green | Sales | Title Transfer | Yellow | Title Transfer | Sales | | | | Sales/Production | | | | Sales/Production | | | | Sales/Production | | | | Sales/Production | | | | Sales/Production | | | | Sales/Production | | | | | x |
| Yellow | PS | FEP | ADG | PS3 | 3 | BS3 | 0000-00-00 | 103 | 180 | 2019-12-16 | 2019-12-20 | Yellow | Green | Rollup | Green | Sales | Title Transfer | Yellow | Title Transfer | Sales | Rollup | Rollup | Rollup | Sales/Production | Rollup | Rollup | Rollup | Sales/Production | Rollup | Rollup | Rollup | Sales/Production | Rollup | Rollup | Rollup | Sales/Production | Rollup | Rollup | Rollup | Sales/Production | Rollup | Rollup | Rollup | Sales/Production | | Shipped | | | |
| Rollup | T6T | OEM | FEDS | 67C | 5 | BS5 | 0000-00-00 | 105 | 250 | 2019-12-23 | 2019-12-22 | Rollup | Green | Rollup | Green | Sales | Title Transfer | Yellow | Title Transfer | Sales | Shipped | Rollup | Shipped | Sales/Production | Shipped | Rollup | Shipped | Sales/Production | Shipped | Rollup | Shipped | Sales/Production | Shipped | Rollup | Shipped | Sales/Production | Shipped | Rollup | Shipped | Sales/Production | Shipped | Rollup | Shipped | Sales/Production | | Shipped | | | x |
FYI, I have 8 Days in total, each Day is a combination of 4 columns with the exact same order: Sales, Production, Day, Status. The range is from column N to column BS (or AS in an actual Excel workbook).
As seen from the table:
1) the 1st row did exactly what I wanted. It did evaluate correctly the "Title Transfer" in column Sales/column R (of Day 2) to be the last Sales column that has "Title Transfer" and return an "x" in column BX (or column AX in my excel file).
2) the 2nd row, the codes returned both correct and wrong results.
I had put "Title Transfer" in a Sales column first, which the Macro then returned an "x" in column BX. That's correct.
However, when I put "Shipped" in column BU after having put "Title Transfer" first in column BX, the "x" was replaced by the Shipped codes I posted above. It did return "Rollup" for all empty Sales and Production cells when I put "Shipped" in column BU (47th column or column AU in my excel file). But the "x" to indicate Title Transfer was gone.
So here comes the problem I've been struggling with for the past week. Can you please advise how I can fix this problem?
3) the 3rd row is what I wanted my codes did if both "Shipped" in column BU and "x" in column BX (apparently it won't work)
To be short, my codes should have done the following:
1) If "Shipped" in column BU (AU in an actual Excel file) and no "x" in column BX (AX in an actual Excel file), then return "Rollup" for all empty Sales and Production cells
2) If "Title Transfer" in the last Sales column and no "Shipped" in column BU (AU in an actual Excel file), return "x" in column BX (AX in an actual Excel file)
3) If "Title Transfer" in the last Sales column (has to happen first) and "Shipped" in column BU (happens later) (AU in an actual Excel file), return "x" in column BX and "Shipped" in all empty Sales and Production cells
Can you please help how to get it to work that way? Thanks a lot and please let me know if you need more info.
Ps: This is what MasterChange has:
Public Sub MasterChange(SPD As Range)
Dim rSales As Range
Dim rProduction As Range
Dim rDay As Range
Set rSales = SPD.Cells(1, 1)
Set rProduction = SPD.Cells(1, 2)
Set rDay = SPD.Cells(1, 3)
Application.EnableEvents = False
If rSales = "Rollup" And rProduction = "Rollup" Then
rDay = "Rollup"
ElseIf rSales = "Rollup" And rProduction = "Green" Then
rDay = "Green"
ElseIf rSales = "Rollup" And rProduction = "Yellow" Then
rDay = "Yellow"
'I have approximately 40 Ifs statements like those but above are just a few for demonstration
End If
Application.EnableEvents = True
End Sub
I'm trying to create a task scheduler in excel. I'll have a start month and an end month, but I'd like to fill in the periods in between. For instance, right now my table looks like this:
+--------+-------+-----+-------+-----+-----+-----+-----+-----+
| Task | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug |
+--------+-------+-----+-------+-----+-----+-----+-----+-----+
| Task A | Start | | | | End | | | |
+--------+-------+-----+-------+-----+-----+-----+-----+-----+
| Task B | | | Start | End | | | | |
+--------+-------+-----+-------+-----+-----+-----+-----+-----+
| Task C | Start | | | | | End | | |
+--------+-------+-----+-------+-----+-----+-----+-----+-----+
For "Task A", I'd like to have the cells in between Jan - May have some text like "Work" or something similar.
So the final table would like this:
+--------+-------+------+-------+------+------+-----+-----+-----+
| Task | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug |
+--------+-------+------+-------+------+------+-----+-----+-----+
| Task A | Start | Work | Work | Work | End | | | |
+--------+-------+------+-------+------+------+-----+-----+-----+
| Task B | | | Start | End | | | | |
+--------+-------+------+-------+------+------+-----+-----+-----+
| Task C | Start | Work | Work | Work | Work | End | | |
+--------+-------+------+-------+------+------+-----+-----+-----+
This is a dynamically changing table, so hard-coding the text in there isn't an option.
Update:
Because this table is dynamic, this table is linked to a table on another tab. It pulls the data with a simple formula "=Sheet1!B2" dragged across the table.
This is assuming that your data starts on cell A1. You will need to change the for loops for the row and column counter if it does not.
Sub fillTask()
Dim intRow As Integer, intStartFlg As Integer
Dim mySht As Worksheet
Set mySht = Sheets("Sheet1")
intStartFlg = 0
'get last row
intRow = mySht.Cells(mySht.Rows.Count, "A").End(xlUp).Row
'loop through each task
For i = 2 To intRow
'Clear previous loop
For j = 2 To 13
If mySht.Cells(i, j) <> "Start" Or mySht.Cells(i, j) <> "End" Then mySht.Cells(i, j).ClearContents
Next j
'loop through each month
For j = 2 To 13
If mySht.Cells(i, j) = "end" Then Exit For
If intStartFlg = 1 Then mySht.Cells(i, j) = "Work"
If mySht.Cells(i, j) = "Start" Then intStartFlg = 1
Next j
intStartFlg = 0
Next i
End Sub
This is a follow up to my previous question (Retrieving information of OLEObjects from Workbook with VBA)
Scenario: I am trying to retrieve data from a worksheet. The data might be normal strings or number or might be encased in check boxed (checked or not).
Data example:
+---------+-------+------------------+------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+------+------------------+
| value x | rfd | checkbox for rfd | nfd | checkbox for nfd |
+---------+-------+------------------+------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+------+------------------+
Obs: In this example the "checkbox for rfd/nfd" is a normal checkbox (either form or activex), and depending on the item in that sheet, either might be selected.
Objective: What I am trying to do is read the worksheet in 2 steps: First read all the data that is directly called, so I use the code:
Sub Test_retrieve()
' this will get all non object values from the sheet
Dim array_test As Variant
Dim i As Long, j As Long
array_test = ThisWorkbook.Sheets(1).UsedRange
For i = 1 To ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To ThisWorkbook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
ThisWorkbook.Sheets(2).Cells(i, j) = array_test(i, j)
Next j
Next i
End Sub
to get:
+---------+-------+------------------+------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+------+------------------+
| value x | rfd | | nfd | |
+---------+-------+------------------+------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+------+------------------+
Next I am trying to reach all the objectives/shapes in my worksheet. I used the following code to get name, value (checked of not) and location of all activex objects:
Sub getavticeboxvalue()
' this will get the names and values (as binary) of all the activex controlbox objects in the sheet
Dim objx As Object
Dim i As Long
i = 1
For Each objx In ThisWorkbook.Sheets(1).OLEObjects
If objx.Object.Value = True Then
ThisWorkbook.Sheets(3).Cells(i, 1).Value = 1
ThisWorkbook.Sheets(3).Cells(i, 2).Value = objx.Name
ThisWorkbook.Sheets(3).Cells(i, 3).Value = objx.BottomRightCell.Address
ElseIf objx.Object.Value = False Then
ThisWorkbook.Sheets(3).Cells(i, 1).Value = 0
ThisWorkbook.Sheets(3).Cells(i, 2).Value = objx.Name
ThisWorkbook.Sheets(3).Cells(i, 3).Value = objx.BottomRightCell.Address
End If
i = i + 1
Next objx
End Sub
Which yields something like:
+-------+-----------+----------+
| value | name | location |
+-------+-----------+----------+
| 0 | checkbox1 | $C$2 |
+-------+-----------+----------+
| 1 | checkbox2 | $E$2 |
+-------+-----------+----------+
I would then proceed to feed the values (1s and 0s), to the first table, in the place where the checkboxes originally where (location).
Issue: When I try the same procedure for Form Control (instead of activex), I have less options, and although I can look for them (ThisWorkbook.Sheets(1).Shapes.Type = 8) I cannot find their name or location.
Question: Is there a way to find their name and location? Is there a more efficient way to reach the result?
Objective:
+---------+-------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+
| value x | rfd | 0 | nfd | 1 |
+---------+-------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+
I am trying to create a button on an access form that would copy the information of an excel file, and paste it into an access table that looks like this:
An example excel file I'm trying to paste from is
here on this site (click the excel icon).
The problem is that the format on the data of the excel file is completely off, it doesn't align with how I set up my data labels on the Access table. What I want to do is select the Excel data and copy it, then in access use a button that, on click, gets the information from the clipboard, arranges the rows, eliminates extra spaces and arranges columns etc, and puts the information on the Access table in an orderly manner.
I just started learning vba and I have been trying everything I can think of for days now without success, meaning that I am able to get the data in the way I want to into the clipboard but I cannot get it from the clipboard into the access able.
Please help! Thank you!
Code I have so far
Sub cmdCopy_Click()
Dim objData As New MSForms.DataObject
Dim strText As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim ComponentNumber As Integer
Dim ComponentText As String
Dim ComponentBlock(100) As Long
Dim ComponentContent(100) As String
Dim ComponentCount As Integer
Dim ComponentStart As Long
Dim ComponentEnd As Long
Dim ComponentLength As Integer
Dim SearchChar As String
Dim Component(100, 2) As Long
Dim LineArray(8000) As String
Dim labname As Integer
Dim TestString As String
Dim ReferenceRangeStart As Integer
Dim Position As String
Dim ColumnDatePosition(6) As Integer
Dim ColumnDateCount As Integer
Dim ComponentBlockLength As Long
Dim PreliminaryArray(10000, 10) As Variant
ComponentCount = 0
'get text from Clipboard
objData.GetFromClipboard
strText = objData.GetText()
' replace double empty lines with single
StrLength = Len(strText)
strText = Replace(strText, Chr(13) & Chr(10) & Chr(13) & Chr(10), Chr(13) &
Chr(10))
For i = 10 To StrLength
If Mid(strText, i, 9) = "Component" Then
ComponentBlock(ComponentCount) = i
ComponentCount = ComponentCount + 1
i = i + 9
End If
Next i
' separate clipboard into component blocks
ComponentStart = 1
For i = 0 To ComponentCount - 1
ComponentContent(i) = Mid(strText, ComponentStart, ComponentBlock(i) - ComponentStart)
ComponentStart = ComponentBlock(i)
Next i
TotalBlocks = i - 1
' determine column spacing
SearchChar = Chr(13) & Chr(10)
ArrayLength = 0
For k = 0 To TotalBlocks
Next k
ComponentLength = InStr(ComponentContent(k), SearchChar) + 1
'Determine where Reference Range starts
ReferenceRangeStart = InStr(1, ComponentContent(k), "Latest")
'Determine position of each date column
ColumnDateCount = 0
For m = 0 To 6
ColumnDatePosition(m) = 0
Next m
ComponentLength = InStr(ComponentContent(k), SearchChar) + 1
'Determine where Reference Range starts
ReferenceRangeStart = InStr(1, ComponentContent(k), "Latest")
'Determine position of each date column
ColumnDateCount = 0
For i = ReferenceRangeStart + 7 To ComponentLength - 10
Position = Mid(ComponentContent(k), i, 6)
If Position Like "##/##/" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
If Position Like "#/##/#" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
If Position Like "#/#/##" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
If Position Like "##/#/#" Then
ColumnDatePosition(ColumnDateCount) = i
i = i + 6
ColumnDateCount = ColumnDateCount + 1
End If
Next i
'Debug.Print ColumnDatePosition(0), ColumnDatePosition(1), ColumnDatePosition(2), ColumnDatePosition(3), ColumnDatePosition(4), ColumnDatePosition(5)
'Length of component line is ComponentLength
'Reference Range starts at ReferenceRangeStart
'ColumnDateCount indicates how many date columns of labs are present
'ColumnDatePosition(ColumnDateCount) stores the date positions
'ComponentContent(ComponentCount) represents the text block for each component block
'Mid(ComponentContent(0), ColumnDatePosition(1), 10), Mid(ComponentContent(0), ColumnDatePosition(2), 10), Mid(ComponentContent(0), ColumnDatePosition(3), 10)
LineLength = Len(ComponentContent(k)) / ComponentLength
For i = 1 To LineLength
If Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, 9) <> "Component"
And Not Asc(Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, 1)) = 32
Then
j = 0
Do While ColumnDatePosition(j + 1) > 0
If Asc(Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, 1)) <> 32 Then
'ArrayLength,0 is component(lab name)
PreliminaryArray(ArrayLength, 0) = Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, ReferenceRangeStart - 1)
DateLength = ColumnDatePosition(j + 1) - ColumnDatePosition(j)
ReferenceLength = ColumnDatePosition(0) - ReferenceRangeStart
'ArrayLength,1 is reference range
PreliminaryArray(ArrayLength, 1) = Mid(ComponentContent(k), ReferenceRangeStart + (i - 1) * ComponentLength, ReferenceLength)
'ArrayLength,2 is date
PreliminaryArray(ArrayLength, 2) = Mid(ComponentContent(k), ColumnDatePosition(j), 10)
PreliminaryArray(ArrayLength, 2) = CDate(PreliminaryArray(ArrayLength, 2))
'ArrayLength,3 is lab value
PreliminaryArray(ArrayLength, 3) = Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, DateLength)
ArrayLength = ArrayLength + 1
End If
j = j + 1
Loop
If Asc(Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, 1)) <> 32 Then
PreliminaryArray(ArrayLength, 0) = Mid(ComponentContent(k), (i - 1) * ComponentLength + 1, ReferenceRangeStart - 1)
PreliminaryArray(ArrayLength, 1) = Mid(ComponentContent(k), ReferenceRangeStart + (i - 1) * ComponentLength, ColumnDatePosition(0) - ReferenceRangeStart)
PreliminaryArray(ArrayLength, 2) = Mid(ComponentContent(k), ColumnDatePosition(j), 10)
PreliminaryArray(ArrayLength, 2) = CDate(PreliminaryArray(ArrayLength, 2))
PreliminaryArray(ArrayLength, 3) = Mid(ComponentContent(k), ColumnDatePosition(j) + (i - 1) * ComponentLength, ComponentLength - ColumnDatePosition(j) - 2)
ArrayLength = ArrayLength + 1
End If
End If
Next i
Changing to a monospaced font reveals that data is transposed into 4 space delimited columns.
Using Range.TextToColumns() to split and WorksheetFunction.Transpose(.UsedRange.Value) to transpose the data, we get a standard table with 11 columns by 3 rows.
+------------------------+--------------+-------------------+-------------------------+-----------+-----------------------+---------------------------+-----------------------------+-------------------------------+----------------------------+----------------+---------------------------+---------------------+--------------------------+-----------------------+------------------------+---------------------+----------------------+-----------------------+-------------------------+-----------------+-----------------------+-----------------+------------------------+----------------------+------------------+---------------+-------------------------+-----------------+----------------------+------------------------+-------------------+----------------------+----------------------+---------------+---------------+--------------+
| Component | Color, Urine | Appearance, Urine | Specific Gravity, Urine | Urine pH | Protein Semiquant, UA | Glucose, Urine, Semiquant | Ketones, Urine, Qualitative | Bilirubin, Urine, Qualitative | Hemoglobin Pigments, Urine | Nitrite, Urine | Leukocyte Esterase, Urine | Urobilinogen, Urine | White Blood Cells, Urine | White Blood Cells, UA | Red Blood Cells, Urine | Red Blood Cells, UA | Hyaline Casts, Urine | Granular Casts, Urine | Epithelial Cells, Urine | Bacteria, Urine | Mucous Threads, Urine | Crystals, Urine | White Blood Cell Count | Red Blood Cell Count | Hemoglobin | Hematocrit | Mean Corpuscular Volume | Mean Corpus Hgb | Mean Corpus Hgb Conc | RBC Distribution Width | Platelet Count | Mean Platelet Volume | Nucleated RBC Number | Neutrophil % | Lymphocytes % | Monocyte % |
+------------------------+--------------+-------------------+-------------------------+-----------+-----------------------+---------------------------+-----------------------------+-------------------------------+----------------------------+----------------+---------------------------+---------------------+--------------------------+-----------------------+------------------------+---------------------+----------------------+-----------------------+-------------------------+-----------------+-----------------------+-----------------+------------------------+----------------------+------------------+---------------+-------------------------+-----------------+----------------------+------------------------+-------------------+----------------------+----------------------+---------------+---------------+--------------+
| Latest Ref Rng & Units | | | 1.003 - 1.030 | 4.6 - 8.0 | Negative | Negative mg/dL | Negative | Negative | Negative | Negative | Negative | 0.2 - 1.0 mg/dL | 0 - 5 /[HPF] | 0 - 27 /uL | 0 - 5 /[HPF] | 0 - 27 /uL | 0 - 1 /[LPF] | None seen /[LPF] | /[HPF] | None-few /[HPF] | None-few /[LPF] | None-few /[HPF] | 4.50 - 11.00 K/cu mm | 4.00 - 5.20 M/cu mm | 12.0 - 15.0 g/dL | 36.0 - 46.0 % | 80.0 - 100.0 fL | 26.0 - 34.0 pg | 31.0 - 37.0 g/dL | 11.5 - 14.5 % | 150 - 350 K/cu mm | 9.2 - 12.7 fL | 0.00 - 0.01 K/cu mm | 40.0 - 70.0 % | 24.0 - 44.0 % | 2.0 - 11.0 % |
| 12/19/2016 | Yellow | Clear | 1.012 | 6 | Negative | Negative | Negative | Negative | Small (A) | Negative | Moderate (A) | <=1.0 | 0 | 1 | 1 | 3 | 0 | 0 | <1 | None | Rare | None | | | | | | | | | | | | | | |
| 1/24/2017 | | | | | | | | | | | | | | | | | | | | | | | 1.82 (L) | 4.71 | 12.6 | 39.3 | 83.4 | 26.8 | 32.1 | 13.1 | 165 | 12.5 | 0 | 42.4 | 37.9 | 16.5 (H) |
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+------------------------+--------------+-------------------+-------------------------+-----------+-----------------------+---------------------------+-----------------------------+-------------------------------+----------------------------+----------------+---------------------------+---------------------+--------------------------+-----------------------+------------------------+---------------------+----------------------+-----------------------+-------------------------+-----------------+-----------------------+-----------------+------------------------+----------------------+------------------+---------------+-------------------------+-----------------+----------------------+------------------------+-------------------+----------------------+----------------------+---------------+---------------+--------------+
Code
Sub RealignData()
Dim data As Variant
With Worksheets("Sheet1")
.UsedRange.TextToColumns Destination:=.Range("A1"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(79, 1), Array(128, 1), Array(154, 1)), TrailingMinusNumbers:=True
data = WorksheetFunction.Transpose(.UsedRange.Value)
.UsedRange.ClearContents
Range("A1").Resize(UBound(data), UBound(data, 2)).Value = data
End With
End Sub
This should make the data easier to work with. As far as getting it into Access there are better way then copy and paste. I recommend learning how to use Adodb.Recordset.AddNew.
I have a long excel file which contains numbers collected from a website. Less than 1% of the cells contain zero due to an error from the source. Therefore, I want to find update those cells and interpolate them with the nearest values. The length of the zero cells is some time single, hence I can simply take the average of the nearest non-zero values. However, a few places it is longer than one, hence I need to use linear interpolation.
Sample extracted data
+---+------+------+------+------+------+------+------+------+---+---+---+---+---+---+---+---+------+------+------+------+------+------+------+------+------+
| | A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y |
+---+------+------+------+------+------+------+------+------+---+---+---+---+---+---+---+---+------+------+------+------+------+------+------+------+------+
| 1 | 4058 | 4048 | 4049 | 4082 | 4090 | 4115 | 4118 | 4109 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 3990 | 4058 | 4064 | 4053 | 4057 | 4093 | 4123 | 4137 | 4133 |
+---+------+------+------+------+------+------+------+------+---+---+---+---+---+---+---+---+------+------+------+------+------+------+------+------+------+
Here's a very general script that might do something like that. It is only tested on positive values and ten rows, so you will definitely need to adapt it to many corner cases - but it should point you in the right direction:
Sub Interpolate()
Dim valueToTop As Integer
For Row = 1 To 10
valueToTop = -1
valueToBottom = -1
If Cells(Row, 1).Value = 0 Then
RowToTop = Row - 1
Do While RowToTop > 0
If Cells(RowToTop, 1).Value > 0 Then
valueToTop = Cells(RowToTop, 1)
Exit Do
End If
RowToTop = RowToTop - 1
Loop
Debug.Print valueToTop
Debug.Print RowToTop
RowToBottom = Row + 1
Do While RowToBottom > 0
If Cells(RowToBottom, 1).Value > 0 Then
valueToBottom = Cells(RowToBottom, 1)
Exit Do
End If
RowToBottom = RowToBottom + 1
Loop
Debug.Print valueToBottom
Debug.Print RowToBottom
Cells(Row, 2).Value = valueToTop + (Row - RowToTop) * (valueToBottom - valueToTop) / (RowToBottom - RowToTop)
End If
Next Row
End Sub