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
Related
this code almost works but im getting a Error "Method 'Range' of object'_Worksheet' failed" when trying to perform the action.
any ideas?
Dim k As Range
For Each k In Sheet2.Range("h6:zz6").Cells
If k = Sheet4.Range("e1").Value Then
Dim i As Long
Dim j As Long
Dim lrow As Long
For i = 10 To 200
If Sheet4.Range("B" & i).Value = "" Then
Exit For
End If
For j = 7 To 10000
If Sheet2.Range("c" & j).Value = "" Then
Exit For
End If
If Sheet4.Range("B" & i).Text = Sheet2.Range("c" & j).Text Then
***Sheet2.Range(k & j).Value*** = Sheet4.Range("b" & i).Value
Exit For
End If
Next j
Next i
Exit For
End If
Next
***Sheet2.Range(k & j).Value***
This part of your loop does not really refer to any cell addresses. It only refers to the number of the iteration itself. Here, for k = 11 and j = 11 it would just yield "(11 & 11)" (of course, it would present an error), not a particular range/cell.
I would try to replace it with:
***Sheet2.Cells(j,k.Column).Value**
In this code snippet, we use the .Cells to give a reference as to which specific cell in the loop we are going to look at.
Dim k As Range
For Each k In Sheet2.Range("h6:zz6").Cells
If k = Sheet4.Range("e1").Value Then
Dim i As Long
Dim j As Long
Dim lrow As Long
For i = 10 To 200
If Sheet4.Range("B" & i).Value = "" Then
Exit For
End If
For j = 7 To 10000
If Sheet2.Range("c" & j).Value = "" Then
Exit For
End If
If Sheet4.Range("B" & i).Text = Sheet2.Range("c" & j).Text Then
***Sheet2.Cells(j,k.Column).Value*** = Sheet4.Range("b" & i).Value
Exit For
End If
Next j
Next i
Exit For
End If
Next
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 have this cell that has a list of things, for example:
[dogs, cats, mice, cows, horses]
And I want to separate them in different cells:
[dogs]
[cats]
[mice]
[cows]
[horses]
Can this be done?
You can easily do this in VBA:
Sub splitString ()
Dim ran, splitS() As String
ran = Range("A1")
splitS() = Split(ran, ",")
For j = LBound(splitS) To UBound(splitS)
Range("B" & (j + 1)) = splitS(j)
Next j
End Sub
If you also want the square brackets, use this code below:
Sub splitStringWithSquareBrackets()
Dim ran, splitS() As String
ran = Range("A1")
ran = Right(ran, Len(ran) - 1)
ran = Left(ran, Len(ran) - 1)
splitS() = Split(ran, ",")
For j = LBound(splitS) To UBound(splitS)
Range("B" & (j + 1)) = "[" & splitS(j) & "]"
Next j
End Sub
With data in cell A1:
Sub dural()
Dim s As String, i As Long
s = Range("A1").Value
s = Mid(s, 2, Len(s) - 2)
ary = Split(s, ", ")
i = 2
For Each a In ary
Cells(i, "A").Value = "[" & a & "]"
i = i + 1
Next a
End Sub
This would do it - You have to select the cell with the cell before running it and it assumes that there is closed brackets ("[" and "]") on either end.
I'll have my best answer now..
Sub ImAmazing()
Dim sString As String, i As Long
If Trim(ActiveCell.Value) = "" Then Exit Sub
ActiveCell.Value = Mid(ActiveCell.Value, 2, Len(ActiveCell.Value) - 2)
Do Until InStr(ActiveCell.Value, ",") = 0
i = i + 1
Cells(ActiveCell.Row + i, ActiveCell.Column).Value = "[" & Left(ActiveCell.Value, InStr(ActiveCell.Value, ",") - 1) & "]"
ActiveCell.Value = Right(ActiveCell.Value, (Len(ActiveCell.Value) - InStr(ActiveCell.Value, ",") - 1))
Loop
ActiveCell.Value = "[" & ActiveCell.Value & "]"
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:
In the list bellow it's an Excel Range, I need to choose two numbers equals to 100 so in return I want to get (30 & 70) or (60 & 40). Can I do that dynamically
I use Excel but if you have any suggestion of other programs it would be fine.
A
30
60
70
40
here the code without verification of duplicated pairs
Sub test()
Dim x&, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
If oCell1.Value + oCell2.Value = 100 Then
Dic.Add x, "(" & oCell1.Value & " & " & oCell2.Value & ")"
x = x + 1
End If
Next
Next
For Each Key In Dic
Debug.Print Key, Dic(Key) 'output in immediate window all possible
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
here the code with verification of duplicated pairs
Sub test()
Dim x&, S$, S2$, check%, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
check = 0
If oCell1.Value + oCell2.Value = 100 Then
S = "(" & oCell1.Value & " & " & oCell2.Value & ")"
S2 = "(" & oCell2.Value & " & " & oCell1.Value & ")"
For Each Key In Dic
If Dic(Key) = S Or Dic(Key) = S2 Then
check = 1: Exit For
End If
Next
If check = 0 Then
Dic.Add x, S
Debug.Print x, Dic(x)
x = x + 1
End If
End If
Next
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
With your data in A1 thru A4, try this macro:
Sub JustKeepTrying()
Dim N As Long, M As Long, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Do
N = wf.RandBetween(1, 4)
M = wf.RandBetween(1, 4)
If N <> M Then
If Cells(M, 1) + Cells(N, 1) = 100 Then
MsgBox Cells(M, 1).Address & vbTab & Cells(M, 1).Value & vbCrLf _
& Cells(N, 1).Address & vbTab & Cells(N, 1).Value
Exit Sub
End If
End If
Loop
End Sub
Assuming you have in range A1:a11 numbers from 0 to 100 step by 10 [0,10,20,...,90,100] you could use this logic (here, result is highlighted with blue color)
Set BaseRange = Range("A1:a11")
BaseRange.ClearFormats
'first number- rundomly find
With BaseRange.Cells(Int(Rnd() * BaseRange.Cells.Count) + 1)
.Interior.Color = vbBlue
FirstNo = .Value
End With
'second number find by difference- error handling required if there is no matching value for each number
BaseRange.Find(100 - FirstNo).Interior.Color = vbBlue