I have the following code that looks to the original worksheet on row 80 of each column and if it has the text "True" it copies that column to the destination worksheet. It then loops and goes through all of the columns. It works perfect, except I can not figure out how to copy the column widths. - Jordan
'Called from AddWorksheet
Sub CopyFinal(orgSheet As Worksheet, destSheet As Worksheet)
Dim j As Integer '**Why is j an Integer and others are Long?
Dim lastColumn As Long
Dim benRow As Long
j = 2
lastColumn = 2
'Counts the number of benefits on each sheet. Assumes that they will not go past row 40
benRow = WorksheetFunction.CountA(orgSheet.Range("B3:B40"))
Application.ScreenUpdating = False
Do Until IsEmpty(orgSheet.Cells(3, j))
If orgSheet.Cells(80, j) = True Then
orgSheet.Cells(3, j).Resize(benRow).Copy destSheet.Cells(3, lastColumn) '**Need to paste column widths
End If
j = j + 1
lastColumn = destSheet.UsedRange.Columns(destSheet.UsedRange.Columns.Count).Column + 1
Loop
Application.ScreenUpdating = True
End Sub
Do Until IsEmpty(orgSheet.Cells(3, j))
If orgSheet.Cells(80, j) = True Then
orgSheet.Cells(3, j).Resize(benRow).Copy
With destSheet.Cells(3, lastColumn)
.Paste
.PasteSpecial Paste:=xlPasteColumnWidths
End With
End If
j = j + 1
lastColumn = destSheet.UsedRange.Columns(destSheet.UsedRange.Columns.Count).Column + 1
Loop
Related
I have in column A multiple strings of numbers that look like:
2222222266622222266666222222222222266622666666222
2222266666622222222666662222666222222666222222222
2222266622226666662266622266622222222222222222666
2222222222222666222226662266622226666622222222666
2666662266622222222222222222222666222222666222666
2222266622222666666666662266622222222222222222222
6662266622226662222266622222666222222266622222222
2666622666666222666222222666222222222222222222222
2222266626662666222222266622222222222666222266622
and so on.
I'm trying to find the values that are 90% the same or another percentage that I would choose before I run the program.
The expected result should be in column B how many other cells would share the same structure as much as an percentage with column A, and if it is possible in next column or columns, the cells that gave that similitude
My first try:
Sub Similar()
Dim stNow As Date
Dim DATAsheet As Worksheet
Dim firstrow As Integer
Dim finalrow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim String_i, Len_i, String_j, Len_j
stNow = Now
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set DATAsheet = Sheet1
DATAsheet.Select
firstrow = Cells(1, 2).End(xlDown).Row
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = firstrow To finalrow
For j = firstrow To finalrow
If i > 3 And j > 3 And i <> j Then
String_i = Cells(i, 1).Value
Len_i = Len(String_i)
String_j = Cells(j, 1).Value
Len_j = Len(String_j)
For k = 1 To Len_i
For l = 1 To Len_j
If Mid(String_i, k, 1) = Mid(String_j, l, 1) Then
Cells(j, 2).Value = Cells(j, 2).Value + 1
End If
Next l
Next k
End If
DoEvents
Next j
Application.StatusBar = "Loop 1/1 --- Done: " & Round((i / finalrow * 100), 0) & " %"
Next i
Application.StatusBar = ""
MsgBox "Done"
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it gaves me in column B the results:
259461.00
262794.00
262794.00
262794.00
259461.00
266123.00
259461.00
259461.00
Any help is appreciated.
Thanks!!!
VladMale first we will need lengt of this string - function LEN, and then we will need comparing substrings - function MID. Second function should be made in some loop from first to last character in a string, and every time it will match, some other cell should count how many times it mached and how many not. The posivite result we can divide by the string length * 100 and compare if it is more or less than 90%
I am new to stackoverflow.com and VBA. I have been searching the web for a VBA that will allow me to copy data from sheet 1 that I input and then paste into sheet 2 based off the a cell value match. Once it is copied, it would then clear the data on Sheet 1 without delete the rows.
I work in a call center, and this would be to update equipment based on the desk it is located at.
So I am hoping that once I input all the data into the fields on sheet 1, I can click an activex button and it will search for the desk number on sheet 2 in column A and then update the row (B:Q) with the data from sheet 1.
I have seen some VBA that will copy the data but it only copies to the next empty row of cells.
Here is the code that I have found but is just not right.
Sub MoveRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A5:Q5" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = ("A5") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Any help would be great!
Thanks.
Something like the code below? I assumed the desk number are on column A sheet1 starting at row 2. You will need to adjust the end rows for both sheet though.
Sub MoveRowBasedOnCellValue()
Dim s1 As Sheet1
Set s1 = Sheet1
Dim s2 As Sheet2
Set s2 = Sheet2
Dim s1StartRow As Integer
Dim s1EndRow As Integer
Dim s2StartRow As Integer
Dim s2EndRow As Integer
s1StartRow = 2
s1EndRow = 8
s2StartRow = 2
s2EndRow = 10
Application.ScreenUpdating = False
For i = s1StartRow To s1EndRow
For j = s2StartRow To s2EndRow
If s1.Cells(i, 1) = s2.Cells(j, 1) Then
s1.Range("B" & i & ":Q" & i).Copy
s2.Cells(j, 2).PasteSpecial xlPasteAll
Application.CutCopyMode = False
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I want to create a macro that when activated, will hide all columns and rows that don't have a cell formatted to a certain colour. I adapted a similar sub for columns with content only but this is another step extra that my brain can't seem to get around this morning. For reference, this is what I used to hide all columns that did not have content:
Sub HideCols()
Dim LC As Integer, j As Integer
Dim LR As Integer, curCnt As Integer
Dim k As Integer
Dim Data As Variant
Application.ScreenUpdating = False
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
Data = Range(Cells(1, 1), Cells(LR, LC))
For k = 1 To LR
If Rows(k).Hidden = False And Data(k, j) <> "" Then _
curCnt = curCnt + 1
Next k
Columns(j).Hidden = curCnt < 2
Next j
Application.ScreenUpdating = True
End Sub
Here's how to hide all the row and column of a cell that is black. I'm sure you can modify to fit your need.
Sub hide_cell()
Dim Rng As Range
Dim MyCell As Range
Set Rng = Range("A2:d10")
For Each MyCell In Rng
If MyCell.Interior.ColorIndex = 1 Then
MyCell.EntireRow.Hidden = True
MyCell.EntireColumn.Hidden = True
End If
Next MyCell
End Sub
I have a piece of VB code in excel to hide columns with less than 2 data entries (header as a minimum) and I need to know how to use this to hide columns whilst ignoring information in filtered out rows:
Sub HideCols()
Dim LC As Integer, j As Integer
Dim cl As Range, rng As Range
Set rng = Range("Table1").SpecialCells(xlCellTypeVisible)
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
Columns(j).Hidden = WorksheetFunction.CountA(Columns(j)) < 2
Next j
Application.ScreenUpdating = True
End Sub
This is what I have, a lot of it makes no sense and needs tidying up but that's only as I've been trying to find my own way to no avail.
Thanks!
I'd go like follows
Option Explicit
Sub HideCols()
Dim cols As Range
Dim iCol As Long
With Range("Table1")
Set cols = .Resize(1, 1).Offset(, .Columns.Count + 1)
For iCol = 1 To .Columns.Count
If Application.WorksheetFunction.Subtotal(103, .Columns(iCol).SpecialCells(xlCellTypeVisible)) < 2 Then Set cols = Union(cols, .Cells(1, iCol))
Next iCol
Set cols = Intersect(.Columns, cols)
If Not cols Is Nothing Then cols.EntireColumn.Hidden = True
End With
End Sub
as a side note, if filtering is done out of Autofilter() method then also header rows are not filtered out. in this case you may want to change the right term of If check to < 3
Check if it's hidden first
Sub HideCols()
Dim LC As Integer, j As Integer
Dim LR As Integer, curCnt as Integer
Dim cl As Range, rng As Range
Dim Data As Variant
Set rng = Range("Table1").SpecialCells(xlCellTypeVisible)
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
' its faster to iterate a variant array than it is Cells
Data = Range( Cells(1, 1), Cells(LR, LC) )
for k = 1 to LR
if Rows(k).Hidden = False and Data(k, j) <> "" Then _
curCnt = curCnt + 1
next k
Columns(j).Hidden = curCnt < 2
Next j
Application.ScreenUpdating = True
End Sub