This is far to advanced for me to figure out.
Here is an example of the worksheet layout:
Row# ColA ColB
23 7 Description
24 8 Description
25
26 For cases with
27 SpecialOptionDesc = Yes
28 9 Description
29
30 For cases with
31 SomeOptionDesc = Yes
32 and
33 AnotherOptionDesc = No
34 9 Description
35
36 10 Description
I'm need to consolidate the information in ColB when the them "For cases with" appears, with the cells below it. The information needs to end up on the row that has the identifying number in ColA. So in this case ColB Rows 26, 27, 28, will all be "copied" or whatever into ColB row 28. Likewise, ColB Rows 30 though 34 will all be on ColB row 34. The old rows (26, 27, 30, 31, 33) can be deleted mashed together or whatever. No data on those rows will be needed any longer.
I didn't actually compile this and try it Excel, but I think that it will get you 90% of the way there if not all the way. I am stepping away from the computer for a bit, but will do some testing when I get back.
Dim cellValue As String
Dim i As Integer
Dim j As Integer
Dim strResult As String
Const endRow As Integer = 500
For i = 1 To endRow
If LCase(ActiveSheet.Cells(i, 2).Value) = "for cases with" Then
j = 0
strResult = ""
While ActiveSheet.Cells(i + j, 1).Value = "" And i + j < endRow
strResult = strResult + " " + ActiveSheet.Cells(i + j, 2).Value
' delete stuff after using
ActiveSheet.Cells(i + j, 2).Value = ""
j = j + 1
Wend
ActiveSheet.Cells(i + j, 2) = strResult + " " + ActiveSheet.Cells(i + j, 2)
End If
Next i
Related
Please have a look at the following given code. It does the work but the code gives the values including the duplicates. (see the output)
I couldn't figure out how to extract unique vales instead of duplicates.
S.No Values
1 99.501
2 99.441
3 99.346
4 99.683
5 99.683
6 99.941
7 99.326
8 99.315
9 99.326
10 99.564
11 99.565
12 99.513
13 99.396
14 99.676
15 99.083
16 99.083
17 98.886
18 99.129
19 99.129
20 99.73
My code:
Sub MaxMin()
Dim Rng As Range, Dn As Range, Lg As String
Dim n As Long, c As Long, nRay As Variant
Dim Sm As String, Sp As Variant, ac As Long
Dim col As Integer, R As Long, t
Set Rng = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp))
For n = 1 To 5
Lg = Lg & IIf(Lg = "", Application.Large(Rng, n), "," _
& Application.Large(Rng, n))
Sm = Sm & IIf(Sm = "", Application.Small(Rng, n), "," _
& Application.Small(Rng, n))
Next n
Sp = Array(Split(Lg, ","), Split(Sm, ","))
ReDim Ray(1 To 11, 1 To 4)
Ray(1, 1) = "S.No"
Ray(1, 2) = "Max"
Ray(1, 3) = "S.No"
Ray(1, 4) = "Min"
For ac = 0 To 1
col = IIf(ac = 0, 1, 3)
c = 0
nRay = Range(Range("A2"), Range("b" & Rows.Count).End(xlUp)).Resize(, 2)
c = 1
For n = 0 To 4
For R = 1 To UBound(nRay, 1)
If Not IsEmpty(nRay(R, 2)) And nRay(R, 2) = Val(Sp(ac)(n)) Then
c = c + 1
Ray(c, col) = nRay(R, 1)
Ray(c, col + 1) = nRay(R, 2)
nRay(R, 2) = ""
Exit For
End If
Next R
Next n
Next ac
Range("F1").Resize(6, 4).Value = Ray
End Sub
Output:
S.No Max S.No Min
6 99.941 17 98.886
20 99.73 15 99.083
4 99.683 16 99.083
5 99.683 18 99.129
14 99.676 19 99.129
The modified code should not include "duplicate" only "unique" 5 max and 5 min values with their index positions.
You can use Dictionary Object to get such results which QHarr is referring to like below.
Public Sub GetMinMax()
Dim objDict As Object
Dim i As Long
Set objDict = CreateObject("Scripting.Dictionary")
'\\ Add uniques to list
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Not objDict.exists(Range("B" & i).Value) Then objDict.Add Range("B" & i).Value, Range("A" & i).Value
Next
'\\ Populate output columns
Range("F1").Resize(1, 4).Value = Array("S.No.", "Max", "S.No.", "Min")
For i = 1 To 5
Range("G" & i + 1).Value = Application.Large(objDict.keys, i)
Range("F" & i + 1).Value = objDict.Item(Range("G" & i + 1).Value)
Range("I" & i + 1).Value = Application.Small(objDict.keys, i)
Range("H" & i + 1).Value = objDict.Item(Range("I" & i + 1).Value)
Next
End Sub
I have an excel problem I really need help with!
I want to use functions in column Day1 and Day2.
Goal: To check each cell and make sure it doesn't exceed 27. If it does, get the difference between the cell value and 27, carry over the difference and add to the next cell.
Example, in column Day1, it will check if 13 is greater than 27. It's not so it will leave that value as it is. Same with 14 and 26. The next value in Day1 Column is 29 which is greater than 27, so it will change that cell value to 27 and carry over the difference (29-27)=2 and add to the cell below so 31 + 2 = 33. Now 33 is greater than 27 so it will again change that value to 27 and carry over the difference (33-27) = 6 and add it to first cell in Day2 Column: 6 + 5=11.
The process will be repeated for Day2 column as well. If the last value in Day2 column doesn't exceed 27, then leave as it is. Move to the next column and repeat that process of checking if cell value is greater than 27.
Current:
Time Day1 Day2
Hour0 13 5
Hour1 14 15
Hour2 26 29
Hour3 29 26
Hour4 31 4
Desired:
Time Day1 Day2
Hour0 13 11
Hour1 14 15
Hour2 26 27
Hour3 27 27
Hour4 27 5
Now I'm not an excel expert so I tried few if statements but don't think that is the way to solve this problem. I did, if(A1>27, 27, A1) which is checking if A1 is greater than 27, change that value to 27 else leave that value as it is. But then I also need another if statement, if(A1>27, A2=(A1-27) + A2, A1)
Trying to find a way to combine those 2 if statements or are there other excel functions/secrets that I can use?
Please any help is appreciated.
Thanks!!
Using VBA, with a "carry forward" variable to keep track of how much is able to be allocated to the next cell:
Sub runMe()
Dim lastCol As Long
Dim lastRow As Long
Dim c As Long
Dim r As Long
Dim cf As Double
With ActiveSheet
'assumes headings in row 1, and column 1
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For c = 2 To lastCol
For r = 2 To lastRow
cf = cf + CDbl(.Cells(r, c).Value)
If cf > 27 Then
.Cells(r, c).Value = 27
cf = cf - 27
Else
.Cells(r, c).Value = cf
cf = 0
End If
Next
Next
'place any final carry forward into a new column
If cf > 0 Then
.Cells(2, lastCol + 1).Value = cf
Else
.Cells(2, lastCol + 1).ClearContents
End If
End With
End Sub
Your best bet is to use Visual Basic. Insert the following code into your sheet and run it. It will do what you are looking for.
Sub Test()
Dim lngLastRow As Long
Dim lngLoopCtr As Long
Dim value_1 As Long
Dim value_2 As Long
lngLastRow = Range("A" & Rows.Count).End(xlUp).Row
For lngLoopCtr = 2 To lngLastRow Step 1
value_1 = Range("B" & lngLoopCtr)
value_2 = Range("B" & lngLoopCtr + 1)
If value_1 > 27 Then
Range("B" & lngLoopCtr + 1) = value_2 + (value_1 - 27)
Range("B" & lngLoopCtr) = 27
End If
Next lngLoopCtr
For lngLoopCtr = 2 To lngLastRow Step 1
value_1 = Range("C" & lngLoopCtr).Value
value_2 = Range("C" & lngLoopCtr + 1).Value
If value_1 > 27 Then
Range("C" & lngLoopCtr + 1) = value_2 + (value_1 - 27)
Range("C" & lngLoopCtr) = 27
End If
Next lngLoopCtr
End Sub
I have data in column B that I need to loop through and then copy the corresponding value in column D for each row, to another sheet in the same workbook.
I need a code written to search through every value in Column B, return the corresponding value in Column D for the same row, and then find the next numbers in order from the given range(in this case I have set it from 7 to 10).
So loop through Column B, find values 7, 7a, 8, 9, 10 in that order (even if a larger value is located before a lower value as you go down), and copy the corresponding values in Column D to another sheet.
Excel Data Chart in Sheet3 (Column A is not needed):
A B C D E
1 1a 78.15 77.68 This is row 7
1a 2 77.18 76.92
2 3 76.92 76.63
3 4 76.13 75.78
4 4a 75.78 75.21
4a 5 75.11 74.87
5 5a 74.87 74.69
5a 6 73.94 73.6
6 6a 73.1 72.71
6a 6b 72.41 72.18
6b 10 72.18 71.6
10 11 71.3 70.89
11 12 70.89 69.83
12 13 69.83 68.68
13 14 68.68 67.68
14 15 67.63 66.46
15 16 66.01 64.84
16 16a 64.24 63.72
16a 16b 56.82 56.37
16b 16c 56.37 55.18
16c OUT 47.28 47.27
7 7a 83.12 76.07
7a 8 76.17 75.99
8 9 74.79 74.41
9 6 74.51 74 This is row 31
My problem: When the code encounters a cell containing letters AND numbers, it skips that cell and moves to the next cell in that range containing only numbers. How do I edit/re-write the code to INCLUDE alphanumeric values in the search criteria?
Here is my code that loops through column B but excludes cells with letters and numbers:
Sub EditBEST()
Dim Startval As Long
Dim Endval As Long 'Finds values corresponding
'to input in B and C
Dim LastRow As Long
LastRow = Sheets("Sheet3").range("B" & Rows.Count).End(xlUp).Row
Startval = Worksheets("Sheet3").Cells(1, "O").Value
Endval = Worksheets("Sheet3").Cells(1, "P").Value
StartRow = 2 'row that first value will be pasted in
For x = 7 To LastRow 'decides range to search thru in "Sheet3"
If Sheets("Sheet3").Cells(x, 2).Value >= 7 And Sheets("Sheet3").Cells(x, 2).Value <= 10 Then 'if cell is not blank
Sheets("Sheet4").Cells(StartRow, 2).Value = _
Sheets("Sheet3").Cells(x, 4).Value 'copy/select cell value in D
StartRow = StartRow + 1 'cell.Offset(0, 1).Value =
End If
If Sheets("Sheet3").Cells(x, 3) >= 7 And Sheets("Sheet3").Cells(x, 3).Offset(0, 1) <= 10 Then
Sheets("Sheet4").Cells(StartRow, 2).Value = _
Sheets("Sheet3").Cells(x, 5).Value
StartRow = StartRow + 1
End If
Next x
End Sub
Thank you
The main issue you are having is that you're conditional check filters out any string values. As # Grade 'Eh' Bacon pointed out, you need to provide some way to handle string values.
You also have some comments that are wrong or misleading.
For example, here, you have added the comment "if cell is not blank" but this is not what you are actually checking.
If Sheets("Sheet3").Cells(x, 2).Value >= 7 And Sheets("Sheet3").Cells(x, 2).Value <= 10 Then 'if cell is not blank
If you want to check if a cell is blank, you can check it's length. E.g.:
If Len(Sheets("Sheet3").Cells(x, 2).Value) > 0 Then
Now, that's really not entirely necessary for this procedure, but I just wanted to point it out since your comment indicates you were trying to do something different than your code was doing.
I haven't tested your code, but I wrote a function for pulling a single out of a string for you. This is all untested, so you may need to debug it, but should get your string problem sorted.
Sub EditBEST()
Dim Startval As Long
Dim Endval As Long 'Finds values corresponding
'to input in B and C
Dim StartOutputRow as Long
Dim LastRow As Long
Dim Val as Long
Dim Val2 as Long
LastRow = Sheets("Sheet3").range("B" & Rows.Count).End(xlUp).Row
Startval = Worksheets("Sheet3").Cells(1, "O").Value
Endval = Worksheets("Sheet3").Cells(1, "P").Value
StartOutputRow =2 'first row we will output to
OutputRow = StartOutputRow 'row of the cell to which matching values will be pasted
For x = 7 To LastRow
Val = GetSingleFromString(Sheets("Sheet3").Cells(x, 2).Value)
If Val >= 7 And Val <= 10 Then 'if value is within range
Sheets("Sheet4").Cells(OutputRow , 2).Value = _
Sheets("Sheet3").Cells(x, 4).Value 'copy cell value from D #the current row to column B #the output row
OutputRow = OutputRow + 1 'Next value will be on the next row
End If
Val = GetSingleFromString(Sheets("Sheet3").Cells(x, 3).Value)
Val2 = GetSingleFromString(Sheets("Sheet3").Cells(x, 3).Offset(0, 1).Value)
If Val >= 7 And Val2 <= 10 Then
Sheets("Sheet4").Cells(OutputRow , 2).Value = _
Sheets("Sheet3").Cells(x, 5).Value 'copy cell value from E #the current row to column B #the output row
OutputRow = OutputRow + 1
End If
Next x
'Sort the output:
Sheets("Sheet4").Range("B:B").Sort key1:=Range(.Cells(StartOutputRow,2), order1:=xlAscending, header:=xlNo
End Sub
Private Function GetSingleFromString(ByVal InString As String) As Single
If Len(InString) <= -1 Then
GetSingleFromString = -1
Exit Function
End If
Dim X As Long
Dim Temp1 As String
Dim Output As String
For X = 1 To Len(InString)
Temp1 = Mid(InString, X, 1)
If IsNumeric(Temp1) Or Temp1 = "." Then Output = Output & Temp1
Next
If Len(Output) > 0 Then
GetSingleFromString = CSng(Output)
Else
GetSingleFromString = -1
End If
End Function
I have a workbook that has thousands of defined name regions located in various worksheets. I'm trying to extract them all and line them up in another workbook.
Most of the defined name regions are 1 row tall (and hundreds of cols wide)... but a few are 3-4 rows tall.
So for example,
Name1
10 5 10 12 30 10 12 10 5 10 12 30 10 12 ...
Name2
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
For instances where the region is more than one row tall, I'd like to collapse it to a single row by taking the SUM of the entire column.
So Name2 would be copied to the new workbook as the following:
30 33 30 36 90 30 36 30 33 30 36 90 30 36
I have some VBA/VBS written that works perfectly (and fast!) for cases where the region is 1 row tall, but I'm not sure how to handle summing the taller regions in an efficient way.
What's the best way to fill in the question marks below?
My code so far hasn't had to explicitly loop through the cells of a region; I'm hoping that that won't be the case here either. Any advice appreciated!
Dim irow
irow = 0
Dim colsum
'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names
'rem Dont copy any name that isnt visible
If nm.Visible = True Then
'rem Only copy valid references that start with "ByWeek"
If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
'rem Only copy if the range is one row tall
If nm.RefersToRange.Row.Count = 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
wsDest.Range("A3",wsDest.Cells(3,nm.RefersToRange.Columns.Count+1)).Offset(irow, 1).Value = nm.RefersToRange.Value
irow = irow + 1
' rem If the named region is several rows tall, then squish it into one row by taking SUM of each column
elseif nm.RefersToRange.Row.Count > 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
???????????????????????????????????
irow = irow + 1
End If
End If
End if
Next
You can update your code such that it adds all the cells in the given range (nm.RefersToRange), independently upon the number of cells:
Dim irow
irow = 0
'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names
'rem Dont copy any name that isnt visible
If nm.Visible = True Then
'rem Only copy valid references that start with "ByWeek"
If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
If nm.RefersToRange.Rows.Count >= 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
Dim totVal As Long: totVal = 0 'I assumed that target values are Long; update this to the proper type is required
For Each cell In nm.RefersToRange.Cells
If (IsNumeric(cell.Value)) Then totVal = totVal + cell.Value
Next
wsDest.Range("A3", wsDest.Cells(3, nm.RefersToRange.Columns.Count + 1)).Offset(irow, 1).Value = totVal
irow = irow + 1
End If
End If
End if
Next
there is no best way as everyone might think their way is the best.
I would suggest using arrays instead of working with the range objects directly as arrays would have been much faster.
Consider
Now running the code
Option Explicit
Sub Main()
Dim lastRow As Long
Dim lastCol As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Dim arr As Variant
arr = Range(Cells(1, 1), Cells(lastRow, lastCol))
ReDim sumArr(UBound(arr, 2)) As Variant
Dim i As Long
Dim j As Long
Dim colSum As Long
For i = LBound(arr, 1) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
colSum = colSum + arr(j, i)
Next j
sumArr(i) = colSum
colSum = 0
Next i
ReDim finalArray(UBound(sumArr) - 1) As Variant
For i = 1 To UBound(sumArr)
finalArray(i - 1) = sumArr(i)
Next i
Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray
End Sub
Results in
The idea to use arrays is taken from here
And all you need to do is modify the range you want to reprint the array to
Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray
So if you use the above code I think all you'll need to change will be
wsDest.Range("A3").Resize(1, UBound(finalArray, 1) + 1) = finalArray
Here's the code I ended using: It loops through each column for the defined named range. It isn't fast, but it works well enough, as 90% of my ranges are just one row tall.
I've just inserted this code where where it says ????...???? in my question above, :
For j = 1 To nm.RefersToRange.Columns.Count
colsum = 0
For i = 1 To nm.RefersToRange.Rows.Count
If IsNumeric(nm.RefersToRange.Cells(i, j).Value) Then
colsum = colsum + nm.RefersToRange.Cells(i, j).Value
End If
Next
wsDest.Range("A3").Offset(irow, j).Value = colsum
Next
I am using a barcode scanner to do inventory with large quantities and I want to enter the data into excel. I can change the way that the scanner behaves after each scan to do things like tab, return, etc. but my big problem is that in order to efficiently provide the quantity I have to scan the item code (7 digits) and then scan the quantities from 0 to 9 in succession. Such that 548 is really 5, 4, 8 and when using excel it puts each number into a new cell. What I would like to do, but don't have the VBA chops to do it is to have excel check to see if the length is 7 digits or one digit. For each one digit number it should move the number to the next cell in the same row as the previous 7 digit number such that each successive one digit number is combined as if excel were concatenating the cells. Then it should delete the single digits in the original column and have the next row start with the 7 digit barcode number.
I hope this makes sense.
Example:
7777777
3
4
5
7777778
4
5
6
7777779
7
8
9
Should become:
| 7777777 | 345 |
| 7777778 | 456 |
| 7777779 | 789 |
Thanks!!
I set up my worksheet like this:
then ran the below code
Sub Digits()
Application.ScreenUpdating = False
Dim i&, r As Range, j&
With Columns("B:B")
.ClearContents
.NumberFormat = "#"
End With
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
If Len(r) = 7 Then
j = 1
Do Until ((Len(r.Offset(j, 0).Text) = 7) Or (IsEmpty(r.Offset(j, 0))))
Cells(i, 2) = CStr(Cells(i, 2).Value) & CStr(r.Offset(j, 0))
j = j + 1
Loop
End If
Set r = Nothing
Next
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Len(Cells(i, 1)) < 7 Then Rows(i & ":" & i).Delete
Next i
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
and the results Ive got:
This is what I did with what you started but I think your newer solution will work better. Thank you so much mehow!
Sub Digits()
Application.ScreenUpdating = False
Dim i, arr, r As Range
Dim a, b, c, d, e
Dim y
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
Set a = Cells(i + 1, 1)
Set b = Cells(i + 2, 1)
Set c = Cells(i + 3, 1)
Set d = Cells(i + 4, 1)
Set e = Cells(i + 5, 1)
If Len(a) = 7 Then
y = 0
ElseIf Len(b) = 7 Then
y = 1
ElseIf Len(c) = 7 Then
y = 2
ElseIf Len(d) = 7 Then
y = 3
ElseIf Len(e) = 7 Then
y = 4
Else:
y = 0
End If
If Len(r) = 7 Then
arr = Range("A" & i & ":A" & i + y).Value
Range("B" & i & ":F" & i) = WorksheetFunction.Transpose(arr)
End If
Next
Cells.Replace "#N/A", "", xlWhole
Application.ScreenUpdating = True
End Sub