I have two tables
A B C
name surname address
and
A B C D
id address name surname
I need to union the tables and matching the cols, so
table1, colA = table2, colC
table1, colC = table2, colB
etc
I use this code, which works fine, but for big data is slow
Sub unionrep()
Dim lastRow As Long
Sheets("decl").Select
With ActiveSheet
lastRow = .Cells(.Rows.Count, "b").End(xlUp).Row
End With
With Sheets("onl")
tlastRow = .Cells(.Rows.Count, "b").End(xlUp).Row
End With
For i = 1 To lastRow
Sheets("onl").Range("a" & tlastRow + i + 1).Value = Range("a" & i).Value
Sheets("onl").Range("b" & tlastRow + i + 1).Value = Trim(Range("b" & i).Value)
Sheets("onl").Range("c" & tlastRow + i + 1).Value = "*" & Range("c" & i).Value
Sheets("onl").Range("d" & tlastRow + i + 1).Value = Range("g" & i).Value
Sheets("onl").Range("e" & tlastRow + i + 1).Value = Range("d" & i).Value
Sheets("onl").Range("f" & tlastRow + i + 1).Value = ""
Sheets("onl").Range("g" & tlastRow + i + 1).Value = ""
Sheets("onl").Range("h" & tlastRow + i + 1).Value = ""
Sheets("onl").Range("i" & tlastRow + i + 1).Value = Range("e" & i).Value
Sheets("onl").Range("j" & tlastRow + i + 1).Value = Range("i" & i).Value
Sheets("onl").Range("k" & tlastRow + i + 1).Value = Range("f" & i).Value
Next
Sheets("onl").Select
End Sub
You could copy and paste the entire ranges instead of looping through the rows. For example, to copy from column A in the "decl" sheet to column C in the "onl" sheet, something like:
Sheets("decl").Range(Cells(1, 1), Cells(lastRow, 1)).Copy
Sheets("onl").Range("C" & tlastRow + 1).PasteSpecial
Try using arrays:
Sub unionrep()
Dim lastRow As Long
Dim vDataIn, vDataOut
With Sheets("decl")
lastRow = .Cells(.Rows.Count, "b").End(xlUp).Row
vDataIn = .Range("A1:I" & lastRow).Value
End With
ReDim vDataOut(1 To lastRow, 1 To 11)
With Sheets("onl")
tlastRow = .Cells(.Rows.Count, "b").End(xlUp).Row + 1
End With
For i = 1 To lastRow
vDataOut(i, 1) = vDataIn(i, 1)
vDataOut(i, 2) = Trim(vDataIn(i, 2))
vDataOut(i, 3) = "*" & vDataIn(i, 3)
vDataOut(i, 4) = vDataIn(i, 7)
vDataOut(i, 5) = vDataIn(i, 4)
vDataOut(i, 9) = vDataIn(i, 5)
vDataOut(i, 10) = vDataIn(i, 9)
vDataOut(i, 11) = vDataIn(i, 6)
Next
Sheets("onl").Range("a" & tlastRow).Resize(UBound(vDataOut, 1), UBound(vDataOut, 2)).Value = vDataOut
Sheets("onl").Select
End Sub
Related
I have written a program that counts bins that are empty (verified), empty (unverified), and not accessible (bins locked).
I am trying to count the bins that are locked from my Bin Conversions sheet that if they are TRUE (there are 20 that are true), then they are locked and will be counted on my Bin Report sheet.
My Bin Reports sheet counts 1 too many for each group (all groups total 23 instead of 20). A group example would be 4-Pallet, 2.5ft, 2 bins locked (instead of 1).
Bin Report
Bin Conversions
Sub getBinStatusArray()
calc (False)
Dim dSH As Worksheet
Dim brSH As Worksheet
Dim bcSH As Worksheet
Set dSH = ThisWorkbook.Sheets("data")
Set brSH = ThisWorkbook.Sheets("Bin Report")
Set bcSH = ThisWorkbook.Sheets("Bin Conversions")
Dim binLockCell As Byte, binType As String, binSize As Variant, binLocked As Boolean, b As Long, i As Long
Dim dataArray() As Variant
Dim binIDArray As Variant
'Create empty array cells
ReDim Preserve dataArray(1 To dSH.Range("A" & Rows.Count).End(xlUp).Row, 1 To 3)
'Navigates cells
With dSH
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
dataArray = .Range(.Cells(lastrow, 1), .Cells(1,
.Columns.Count).End(xlToLeft)).Value
End With
'Count Bin Conversion Cells
With bcSH
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
.Range("E" & i).Value2 = Application.WorksheetFunction.CountIf(dSH.Range("A:A"), .Range("A" & i).Value2)
Next i
End With
'Generate Bin Report
With brSH
.Cells.ClearContents
.Range("H1").Value = "Filter Input"
.Range("B1").Value = "Bin Type"
.Range("I1").Value = "Bin Type"
.Range("C1").Value = "Bin Height"
.Range("J1").Value = "Bin Height"
.Range("D1").Value = "Verified"
.Range("K1").Value = "Verified"
.Range("E1").Value = "Unverified"
.Range("L1").Value = "Unverified"
.Range("F1").Value = "Bins Locked"
.Range("M1").Value = "Bins Locked"
For i = 2 To lastrow
If bcSH.Range("E" & i).Value = 1 Or Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true") Then
binType = bcSH.Range("B" & i).Value
binSize = bcSH.Range("C" & i).Value
binLocked = bcSH.Range("H" & i).Value
If .Range("b2") = "" Then
.Range("b2").Value = bcSH.Range("B" & i).Value
.Range("c2").Value = bcSH.Range("C" & i).Value
.Range("F2").Value2 = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
ElseIf .Range("b2") <> "" Then
lastrow = brSH.Cells(Rows.Count, 2).End(xlUp).Row
For b = 2 To lastrow + 1
If brSH.Range("B" & b) = binType And brSH.Range("C" & b) = binSize Then
brSH.Range("D" & b) = brSH.Range("D" & b) + bcSH.Range("E" & i)
binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
brSH.Range("F" & b) = binLockCell + brSH.Range("F" & b)
Exit For
ElseIf b = lastrow Then
.Range("b" & b + 1).Value = bcSH.Range("B" & i).Value
.Range("c" & b + 1).Value = bcSH.Range("c" & i).Value
.Range("D" & b + 1).Value = bcSH.Range("E" & i).Value
binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
.Range("F" & b + 1) = binLockCell + .Range("F" & b + 1)
End If
Next b
End If
End If
Next i
Range("b1").CurrentRegion.sort key1:=Range("b1"), order1:=xlAscending, _
key2:=Range("C1"), order2:=xlAscending, Header:=xlYes
End With
calc (True)
End Sub
You are looping For b = 2 To lastrow + 1 but adding a new line when b = lastrow i.e. before the loop has ended. So on the last iteration when b = lastrow + 1 it summates the record again. One fix would be use a flag.
ElseIf .Range("b2") <> "" Then
Dim bExists: bExists = False
lastrow = brSH.Cells(Rows.Count, 2).End(xlUp).Row
' increment existing
For b = 2 To lastrow
If brSH.Range("B" & b) = binType And brSH.Range("C" & b) = binSize Then
brSH.Range("D" & b) = brSH.Range("D" & b) + bcSH.Range("E" & i)
binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
brSH.Range("F" & b) = binLockCell + brSH.Range("F" & b)
bExists = True
Exit For
Next b
' or add new line
If Not bExists Then
.Range("b" & b + 1).Value = bcSH.Range("B" & i).Value
.Range("c" & b + 1).Value = bcSH.Range("c" & i).Value
.Range("D" & b + 1).Value = bcSH.Range("E" & i).Value
binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
.Range("F" & b + 1) = binLockCell + .Range("F" & b + 1)
End If
End If
I have some problems with excel and VBA, in that don't know have much knowledge. I copied text from pdf and it's awful.
I have cells which contain some text.
The problem is that the text from one paragraph is broken down over several cells. At the beginning of each paragraph is a word in bold (e.g. CLR.) which describes the rest of the text. As such, it defines where each paragraph should start. How I can merge these cells into one?
I see
I want
Sub MergeText()
Dim strMerged$, r&, j&, i&
r = 1
Do While True
If Cells(r, 1).Characters(1, 1).Font.Bold Then
strMerged = "": strMerged = Cells(r, 1)
r = r + 1
While (Not Cells(r, 1).Characters(1).Font.Bold) And Len(Cells(r, 1)) > 0
strMerged = strMerged & Cells(r, 1)
r = r + 1
Wend
i = i + 1: Cells(i, 2) = strMerged
Cells(i, 2).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
Else
Exit Do
End If
Loop
End Sub
Modify (if needed) and try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, Count As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) = Left(.Range("A" & i - 1), 1) Then
Count = 0
For j = 1 To Len(.Range("A" & i - 1))
If .Range("A1").Characters(j, 1).Font.FontStyle = "Bold" Then
Count = Count + 1
Else
Exit For
End If
Next j
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
With .Characters(Start:=1, Length:=Count).Font
.FontStyle = "Bold"
End With
End With
.Rows(i).EntireRow.Delete
ElseIf (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) <> Left(.Range("A" & i - 1), 1) Then
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
End With
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
I am surprised there's no answer for this. I have read Setting Dynamic Ranges in VBA and Selecting Dynamic Range and Autofill Dynamic Range Last Row and Last Column and MSDN
I have multiple, distinct ranges on a sheet with varying sizes. I am trying to subtotal column L. I can do it using a hardcoded sum (via subtotal variable) but I want to insert a formula into the cell instead. This requires knowing the starting and end rows for each range. My code almost works. It fails when the range only consists of one row. Even so, I feel there's gotta be a smarter way to do this.
How does one determine the start and end row of a range on a sheet filled with multiple ranges?
For i = 2 To j
If .Cells(i + 1, "L") = "" And .Cells(i + 2, "L") = "" Then
b = .Cells(i - 1, "J").End(xlUp).Row
End If
subtotal = subtotal + .Cells(i, "L").Value2
If .Cells(i, 1) = "" And .Cells(i - 1, "B") <> "" Then
If .Cells(i - 1, "K") = 0 Then
.Cells(i, "K").Value2 = "Check Payment"
'Set sumRng = .Range(.Cells(b, "L"), .Cells(i - 1, "L"))
.Cells(i, "L").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
.Cells(i - 1, "L").Borders(xlEdgeBottom).LineStyle = xlContinuous
total = total + subtotal
subtotal = 0
ElseIf .Cells(i - 1, "K") = "Checking" Then
.Cells(i, "K").Value2 = "EFT Payment"
'Set sumRng = .Range(.Cells(b, "L"), .Cells(i - 1, "L"))
.Cells(i, "L").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
.Cells(i - 1, "L").Borders(xlEdgeBottom).LineStyle = xlContinuous
total = total + subtotal
subtotal = 0
End If
End If
Next
You can loop through the column like this:
For i = 2 To mySheet.Range("B" & Rows.Count).End(xlUp).Row + 1
If Range("B" & i).Value <> vbNullString Then
If Range("B" & i - 1).Value = vbNullString Then
j = i
End If
Else
If Range("B" & i - 1).Value <> vbNullString And Range("B" & i - 1).Formula <> "=SUM(B" & j & ":B" & i - 2 & ")" Then
Range("B" & i).Formula = "=SUM(B" & j & ":B" & i - 1 & ")"
End If
End If
Next i
This uses Match to skip chunks and as such the number or loops are less
With ActiveSheet
Dim b As Long
b = 2
Do Until b = .Rows.Count
Dim x As Variant
x = .Evaluate("Match(True, Index(" & .Range(.Cells(b, "l"), .Cells(.Rows.Count, "l")).Address & " <> """",),0)")
If Not IsError(x) Then
b = b + x - 1
Else
Exit Sub
End If
x = .Evaluate("Match(True, Index(" & .Range(.Cells(b, "l"), .Cells(.Rows.Count, "l")).Address & " = """",),0)")
Dim i As Long
i = b + x - 1
.Cells(i, "l").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
b = i + 2
Loop
End With
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
Do While Cells(i, 1).Value <> ""
....
End If
i = i + 1
Loop
End Sub
Right. It works fine with numbers and stop perfectly. But With Text. It does not stop.
Ideally I want to stop at the last row of my content rather than my last row in Excel. I manage to make it work fine with numbers, but I cannot fix it with Text.
Any help would be great as I am a beginner in VBA.
Sub checkRoutine()
Dim i As Integer
Dim LastRow As Long
i = 1
Do While Cells(i, 1).Value <> ""
If IsNumeric(Cells(i, 1).Value) Then Cells(i, 2).Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
If Not IsNumeric(Cells(i, 1).Value) Then
LastRow = Range("A" & Rows.Count).End(xlUp).row + 1
ActiveSheet.Cells(LastRow, "A").Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
End If
i = i + 1
Loop
End Sub
As suggested by so many people, you need to change to use a For loop:
Sub checkRoutine()
Dim i As Long
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).row
For i = 1 To LastRow
If IsNumeric(Cells(i, 1).Value) Then
Cells(i, 2).Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
Else
LastRow = Range("A" & Rows.Count).End(xlUp).row + 1
Cells(LastRow, "A").Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
End If
Next
End Sub