I have a formula that is making my file very heavy so I am trying to code it into a macro to run and only save the final values. I will need to re-run the macro daily as the values are constantly changing.
Here is my formula:
=IF($J2="P",IF(SUMIFS($D$1:D2,$I$1:I2,I2)<=SUMIFS('On Hand'!C:C,'On Hand'!B:B,I2),IF(SUMIFS('On Hand'!C:C,'On Hand'!B:B,I2)-SUMIFS($D$1:D2,$I$1:I2,I2)<=0,"Shortage",""),"Shortage"),"")
and here is what I have coded so far but it keeps throwing me an error:
Dim J As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim a As Integer
Dim b As Integer
Set ws1 = Worksheets("Jobs")
Set ws2 = Worksheets("On hand")
J = 2
Do While Range(J & "2") <> ""
If Cells(J, 10) <> "P" Then
Cells(J, 19) = ""
Else
If Range("I" & (J - 1) & ":I" & J) = Range("I" & J) Then
a = Range("D" & (J - 1)) + Range(":D" & J)
If ws2.Range("B:B") = ws1.Range("I" & J) Then
b = ws2.Application.Sum(Range("C:C"))
If a <= b Then
If b = a <= 0 Then Range("S" & J) = "Shortage"
Else
Range("S" & J) = ""
J = J + 1
Loop
Related
I have an Excel sheet (doc1) with 4 columns. In "A" I have people names. In "B","C" and "D", I have informations on the CV of each of these people. I would like to extract in another sheet (doc2) these informations in a specific format: For each CV information, I would like to insert a row with the name of the person in "A" and one information about his CV in "B". Basically if I have 3 informations about a person in doc1 (In B,C and D), I want to have 3 rows : In A1, A2 and A3 the name of the person, and in B1, B2 and B3 the person's infos.
I have a macro which does the exact opposite, it is basically doing a Vlookup which throws multiple results. Any idea on how to turn this around? Thanks!
Option Explicit
Sub GO()
Dim J As Long
Dim I As Integer
Dim K As Long
Dim Indice As Long
Dim Tablo
Dim Nb As Integer
Application.ScreenUpdating = False
ReDim Tablo(1 To Range("A" & Rows.Count).End(xlUp).Row - 2, 1 To 2)
Tablo(1, 1) = Range("A2")
Tablo(1, 2) = Range("B2")
Nb = 1
For J = 3 To Range("A" & Rows.Count).End(xlUp).Row
For K = 1 To UBound(Tablo)
If Range("A" & J) = Tablo(K, 1) Then
For I = 1 To UBound(Tablo, 2)
If Tablo(K, I) = "" Then
Tablo(K, I) = Range("B" & J)
Exit For
End If
Next I
If I > UBound(Tablo, 2) Then
ReDim Preserve Tablo(1 To UBound(Tablo), 1 To UBound(Tablo, 2) + 1)
Tablo(K, UBound(Tablo, 2)) = Range("B" & J)
End If
Exit For
ElseIf Tablo(K, 1) = "" Then
Nb = Nb + 1
Tablo(K, 1) = Range("A" & J)
Tablo(K, 2) = Range("B" & J)
Exit For
End If
Next K
Next J
With Sheets("doc2")
.Cells.ClearContents
.Range("A2").Resize(Nb, UBound(Tablo, 2)) = Tablo
.Range("A1") = "Name"
.Range("B1") = "C.V info 1"
.Range("B1").AutoFill .Range("B1").Resize(, UBound(Tablo, 2) - 1), xlFillSeries
End With
End Sub
try somethihng like this:
Function NeverCallAFunctionGO:
dim doc1 as worksheet, doc2 as worksheet
dim lRow as long
'set your doc1 and doc2 sheets
lRow = 1
For i = 1 to doc1.range("A1").end(xldown).row
doc2.range("A" & lRow).value = doc1.range("A" & i).value
doc2.range("B" & lRow).value = doc1.range("B" & i).value
doc2.range("B" & lRow+1).value = doc1.range("C" & i).value
doc2.rangE("B" & lRow+2).value = doc1.rangE("D" & i).value
lRow = lRow + 3
Next i
Sub myfunction()
Dim convert_i, convert_k As String
Dim i, j, k, l As Long
For i = 2 To 583
For k = i + 1 To 583
j = InStr(Range("F" & k).Text, Range("F" & i).Text)
If j > 0 Then
l = InStr(Range("F" & k).Text, " \ ")
If l > 1 Then
convert_i = Range("F" & i).Text & ""
convert_k = Range("F" & k).Text & ""
pos = InStrRev(convert_k, convert_i) - 1
Range("F" & k).Value = Right(convert_k, Len(convert_i) - pos)
Range("F" & k).Value = Range("F" & i).Text + Range("F" & k).Text
Else:
Range("F" & k).Value = Range("F" & i).Value + " \ " + Range("F" & k).Value
End If
End If
Next k
Next i
MsgBox ("Finished ")
End Sub
The code works for the most part however it's inconsistent and I'm baffled as to why. The desired result is like
CP \ CP01 \ CP0103
And through the document I think like at least a good 70 percent is of this format but I do not have the time to go trough remaining 30 percent manually. I would very much appreciate any help.
Please check images below:
The expected result:
enter image description here
Create a Tree
Adjust the values in the constants section.
Option Explicit
Sub createTree()
Const wsName As String = "Sheet1"
Const First As String = "F2"
Const len1 As Long = 2
Const len2 As Long = 4
Const Sep As String = " \ "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim rg As Range
With wb.Worksheets(wsName).Range(First)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
Set rg = .Resize(lCell.Row - .Row + 1)
End With
Dim Data As Variant: Data = rg.Value ' assuming there is data in F3 at least
Dim sLen As Long: sLen = Len(Sep)
Dim tLen As Long: tLen = len1 + sLen + len2
Dim cString As String
Dim cPref1 As String
Dim cPref2 As String
Dim r As Long
For r = 1 To UBound(Data, 1)
cString = Trim(Data(r, 1))
Select Case Len(cString)
Case len1
cPref1 = cString
cPref2 = ""
Data(r, 1) = cString
Case len2
cPref2 = cPref1 & Sep & cString
Data(r, 1) = cPref2
Case Else
If Len(cPref2) = tLen Then
cPref2 = cPref2 & Sep & cString
Else
cPref2 = Left(cPref2, tLen) & Sep & cString
End If
Data(r, 1) = cPref2
End Select
Next r
rg.Value = Data
End Sub
Sub myfunction()
Dim convert_i, convert_k, last_part As String
Dim i, j, k, l As Long
For i = 2 To 583
For k = i + 1 To 583
j = InStr(Range("F" & k).Text, Range("F" & i).Text)
If j > 0 Then
l = InStrRev(Range("F" & k).Text, " \ ")
If l > 0 Then
convert_i = Range("F" & i).Value
convert_k = Range("F" & k).Value
last_part = Right(convert_k, Len(convert_k) - l - 2)
Range("F" & k).Value = Range("F" & i).Text & " \ " & last_part
Else:
Range("F" & k).Value = Range("F" & i).Value & " \ " & Range("F" & k).Value
End If
End If
Next k
Next i
MsgBox ("Finished ")
End Sub
I realised my implementation was terrible, I was confused by getting it almost 70 percent right. The above code got the job done. Might as well delete the question as I don't think it would be of help to anybody.
I got this code but it doesn't seem to run all the way to the end. Gets stuck and debugger just highlights either the Loop keyword or i = i + 1 row. What am I doing wrong?
I tried If statement or For … Next but nothing seems to work.
Sub Macro1()
'
' Macro1 Macro
'
Dim i As Integer
i = 2
Do Until i > 586
Range("B2").Formula = "=sheet2!CS" & i & ""
Range("B3").Formula = "=sheet2!CR" & i & ""
Range("B4").Formula = "=sheet2!CQ" & i & ""
Range("B5").Formula = "=sheet2!CP" & i & ""
Range("B6").Formula = "=sheet2!CO" & i & ""
Range("B7").Formula = "=sheet2!CN" & i & ""
Range("B8").Formula = "=sheet2!CM" & i & ""
Range("B9").Formula = "=sheet2!CL" & i & ""
Range("B10").Formula = "=sheet2!CK" & i & ""
Range("B11").Formula = "=sheet2!CJ" & i & ""
Range("B12").Formula = "=sheet2!CI" & i & ""
Range("B13").Formula = "=sheet2!CH" & i & ""
Range("B14").Formula = "=sheet2!CG" & i & ""
'Copy and PasteSpecial a Range
Range("AL18").Copy
Worksheets("Sheet2").Range("CV" & i & "").PasteSpecial Paste:=xlPasteValues
i = i + 1
Loop
End Sub
Doesn't seem like there's any problems with the code when I tested it..
Here's your code albeit made shorter and see if it works.
Sub Macro1()
Dim i As Long, j As Long
Dim colltr As String
For i = 2 To 586
For j = 2 To 14
colltr = Split(Cells(1, 99 - j).Address, "$")(1)
Range("B" & j).Formula = "=sheet2!" & colltr & i
Next j
'Copy and PasteSpecial a Range
Worksheets("Sheet2").Range("CV" & i & "").value = Range("AL18").value
Next i
End Sub
A Simple Slow Version
Sub LoopTrouble()
Dim i As Integer
Dim j As Integer
For i = 2 To 586
For j = 1 To 13
Sheet1.Cells(j + 1, 2) = Sheet2.Cells(i, 98 - j)
' Sheet1.Cells(j + 1, "B") = Sheet2.Cells(i, 98 - j)
' Sheet1.Range("B" & j + 1) = Sheet2.Cells(i, 98 - j)
Next
Sheet2.Cells(i, 100) = Sheet1.Cells(18, 38)
Next
End Sub
A Faster 'Semi' Array Version
Sub LoopTroubleFaster()
Dim i As Integer
Dim j As Integer
Dim vntLT As Variant
Dim vntPaste As Variant
vntLT = Sheet2.Range(Cells(2, 85), Cells(586, 97)).Value2
ReDim vntPaste(1 To 13, 1 To 1)
For i = 1 To 585
For j = 1 To 13
vntPaste(j, 1) = vntLT(i, j)
Next
Sheet1.Range("B2:B14") = vntPaste
Sheet2.Cells(i + 1, 100) = Sheet1.Cells(18, 38)
Next
End Sub
I currently have a sheet with two columns - 'From' and 'To'. I am trying to create a spreadsheet where each line is an individual value that falls within the ranges currently in each row.
An example (sorry I cannot embed images yet)--
What I have:
What I want:
Try this VBA code,
Sub splitToCodes()
Dim i As Long, j As Long, k As Long
j = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(Cells(i, 1)) Then
For k = Cells(i, 1) To Cells(i, 2)
Cells(j, 4) = k
j = j + 1
Next k
Else
For k = Right(Cells(i, 1), Len(Cells(i, 1)) - 1) To Right(Cells(i, 2), Len(Cells(i, 2)) - 1)
Cells(j, 4) = k
Cells(j, 4) = Left(Cells(i, 1), Len(Cells(i, 1)) - Len(Cells(j, 4))) & k
j = j + 1
Next k
End If
Next i
End Sub
This code loops through the columns A and B and prints the output in column D. Modify as per your needs.
Note:- This code will work only for similar data as in the image as you have not mentioned any other format.
Copy & paste FROM and TO columns under each other and apply remove duplicates function at data block of menu bar.
Here is my super tedious solution:
Option Explicit
Sub Test()
Dim i As Integer, j As Integer, k As Long, sht As Worksheet, lastrow As Long, missingzeroes As Integer, zeroesholder As String, myzeroes As String
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If IsNumeric(Range("B" & i).Value) = True And IsNumeric(Range("A" & i).Value) = True Then
j = Range("B" & i).Value - Range("A" & i).Value
lastrow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
For k = 0 To j
Range("D" & lastrow + 1 + k).Value = Range("A" & i).Value + k
Next k
Else
j = Right(Range("B" & i).Value, 4) - Right(Range("A" & i).Value, 4)
lastrow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
For k = 0 To j
Range("D" & lastrow + 1 + k).Value = Left(Range("B" & i).Value, 1) & Right(Range("A" & i).Value, 4) + k
If Len(Range("B" & i).Value) <> Len(Range("D" & lastrow + 1 + k).Value) Then
missingzeroes = Len(Range("B" & i).Value) - Len(Range("D" & lastrow + 1 + k).Value)
zeroesholder = "000000000000000000000000000000000000000000000000000000000000000000"
myzeroes = Left(zeroesholder, missingzeroes)
Range("D" & lastrow + 1 + k).Value = Left(Range("A" & i).Value, 1) & myzeroes & Right(Range("A" & i).Value, Len(Range("D" & lastrow + 1 + k).Value) - 1) + k
End If
Next k
End If
Next i
End Sub
I have multiple rows which are sometimes in order and sometimes not.
Out of rows which are in order, I would need to create a range, which are not in order just to copy the number.
The thing is, the most rows in order can be even 20.
For example cells:
1
3
5
6
7
8
9
10
13
14
15
There would be:
1
3
5-10
13-15
Is it possible to code it?
Thanks
Assuming your data starts with A1.... and
required results will be printed at C column.
Try with below code
Sub test()
Dim i As Long, lastrow As Long, incre As Long
Dim startno As Variant
Dim endno As Variant
incre = 1
lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Cells(i, 1) = (Cells(i + 1, 1) - 1) Then
startno = Cells(i, 1)
Do While Cells(i, 1) = (Cells(i + 1, 1) - 1)
endno = Cells(i + 1, 1)
i = i + 1
Loop
Cells(incre, 3) = "'" & startno & "-" & endno
incre = incre + 1
Else
Cells(incre, 3) = Cells(i, 1)
incre = incre + 1
End If
Next i
End Sub
if you want the address of all consecutive ranges you could use:
Option Explicit
Sub main()
Dim rangeStrng As String
With Worksheets("MyRowsSheet") '<--| change "MyRowsSheet" with your actual sheet name
rangeStrng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants).Areas.Parent.Address(False, False)
End With
End Sub
if you want only the rows range then you could use:
Option Explicit
Sub main2()
Dim rng As Range
Dim rowsRangeStrng As String
With Worksheets("MyRowsSheet") '<--| change "MyRowsSheet" with your actual sheet name
For Each rng In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
If rng.Rows.Count = 1 Then
rowsRangeStrng = rowsRangeStrng & rng.Rows(1).Row & ","
Else
rowsRangeStrng = rowsRangeStrng & rng.Rows(1).Row & "-" & rng.Rows(rng.Rows.Count).Row & ","
End If
Next rng
End With
If rowsRangeStrng <> "" Then rowsRangeStrng = Left(rowsRangeStrng, Len(rowsRangeStrng) - 1)
End Sub
If I understood your question correctly, you are not looking to address a range, but rather want an output table. This code below should provide you with just that. My input numbers are in column A, and the output is in column B.
Sub sequentials()
Dim tws As Worksheet
Dim tmpRowA, tmpRowB As Integer
Dim seq() As Long
Dim frA, frB, lrA As Integer 'firstrow col A, col B, lastrow of data
Set tws = ThisWorkbook.Worksheets("Sheet1")
frA = 2
frB = 2
lrA = tws.Range("A1000000").End(xlUp).Row
'Input in column A, Output in column B
'Headers in Row 1
ReDim seq(0 To lrA - 1)
seq(0) = -2
seq(1) = tws.Range("A" & frA).Value
tmpRowA = frA
tmpRowB = frB
tws.Range("B" & frB & ":B" & lrA).NumberFormat = "#"
For r = frA + 1 To lrA
If r = 23 Then
r = 23
End If
With tws
seq(r - 1) = .Range("A" & r).Value
If seq(r - 1) = seq(r - 2) + 1 Then
If r = lrA Then
.Range("B" & tmpRowB).Value = .Range("A" & tmpRowA - 1).Value & "-" & seq(r - 1)
End If
Else
If seq(r - 2) = seq(r - 3) + 1 Then
.Range("B" & tmpRowB).Value = .Range("A" & tmpRowA - 1).Value & "-" & seq(r - 2)
Else
.Range("B" & tmpRowB).Value = seq(r - 2)
End If
tmpRowB = tmpRowB + 1
tmpRowA = r + 1
If r = lrA Then
.Range("B" & tmpRowB).Value = seq(r - 1)
End If
End If
End With
Next r
End Sub
Proof of concept: