My code seems to not be working, and I'm not sure why?
Sub Concat()
'Formula to combine the member AC# and Parish Name
Sheets("Risk Partner Data").Select
Dim ACParish As String, i As String
Dim rng As Range
Set rng = Range("A" & Rows.Count).End(x1Up)
ACParish = rng.Row
For i = 2 To ACParish
AcrtiveWorkbook.Sheets("Calc Data").Cells(i, 1) = Cells(i, 1) & Cells(1, 2)
Next i
End Sub
Says that Compile error, Type mismatch and highlights the "i" in For i = 2
My objective:
In another sheet (Risk Partner Data) I have Columns F & E, these are a mixture of text and numbers. I want it to run for all of the active cells in the columns.
I'm new to vba.
i is being used as an integer in the For ... Next but you've declared it as a string; it should be a Long. Same for ACParish.
There is a typo in AcrtiveWorkbook.
You don't need to .Select a worksheet in order mto access it's values.
Should ... = .Cells(i, 1) & .Cells(1, 2) be ... = .Cells(i, 1) & .Cells(i, 2)?
Sub Concat()
'Formula to combine the member AC# and Parish Name
Dim ACParish As long, i As long
with workSheets("Risk Partner Data")
ACParish = .Range("A" & Rows.Count).End(xlUp).row
For i = 2 To ACParish
.parent.workSheets("Calc Data").Cells(i, 1) = .Cells(i, 1) & .Cells(1, 2)
Next i
end with
End Sub
Related
I have to create a report where I get a raw data with a list of transactions, I need my macro to send each transaction to its respective sheets based on if Portfolio name at C Column
I manged to do that, but now I need Transaction of Nokia that fall under 'Cash' from the below given reference sheet, to paste under sheet "Nokia - Cash"
Can someone please help me build the 2nd part of my code which helps to move the if C=Nokia and J = Semi Paid then move to Nokia - Cash?
It is similar to the previous question I have answered.
You don't have to worry about creating the sheets and naming them, the code handles it. It also skips the items which are not found in reference sheet.
It matches the description item with item in your reference sheet, then concats card name with the matched item's category name in order to name the relevant sheet. If this sheet does not exist, it creates and pass the row data, otherwise simply pass the row data.
Sub MyClients()
Dim lastrow As Long, lastcol As Long, matchrow As Long, i As Long, j As Long
Dim wsname As String
lastrow = Worksheets("Raw").Cells(Worksheets("Raw").Rows.Count, 1).End(xlUp).Row
lastcol = Worksheets("Raw").Cells(1, Worksheets("Raw").Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
For i = 2 To lastrow
On Error Resume Next
matchrow = Application.WorksheetFunction.Match(Worksheets("Raw").Cells(i, 10).Value, Worksheets("Reference").Range("A:A"), 0)
If Err.Number = 1004 Then
MsgBox "Couldn't find item: '" & Worksheets("Raw").Cells(i, 10).Value & "' within reference sheet. Skipping row no: " & i
GoTo skip:
End If
wsname = Worksheets("Raw").Cells(i, 3).Value & " - " & Worksheets("Reference").Cells(matchrow, 2).Value
On Error Resume Next
Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(1, 0) = Worksheets("Raw").Cells(i, 1).Value
For j = 1 To lastcol - 1
Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(0, j) = Worksheets("Raw").Cells(i, j).Value
Next j
If Err.Number = 9 Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsname
For j = 1 To lastcol
Worksheets(wsname).Cells(1, j) = Worksheets("Raw").Cells(1, j).Value
Next j
Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(1, 0) = Worksheets("Raw").Cells(i, 1).Value
For j = 1 To lastcol - 1
Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(0, j) = Worksheets("Raw").Cells(i, j).Value
Next j
End If
skip:
Next i
Worksheets("Raw").Activate
Application.ScreenUpdating = True
End Sub
I have a problem with a specific excel task. Although I searched the web thoroughly for tips and parts of code I could use, I was not able to get near a functioning solution.
This is my problem:
I have around 30 Worksheets with two columns each.
The number of Rows varies from WS to WS but the two columns on each sheet are equally long.
The first column of each Sheet contains minimum values and the second column holds the respective maximum values.
E.g.
| A | B
1 | 1000 | 1010
2 | 2020 | 2025
Now I need one single column with all values from these intervals including the Max and Min values.
Preferred solution in Column C:
1000, 1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010, 2020, 2021, 2022, 2023, 2024, 2025
I thought of highlighting the two columns and then activating a macro to generate the list. I would then repeat this process for each WS manually. Some sheets have only 4 to 20 rows but some have over 7000 rows.
And if it helps anything: The numbers are postcodes ;-)
I'd be very grateful for any kind of help.
Thanks in advance!
Try this:
Sub Test()
Dim LastRow As Long, ColIndex As Long
Dim i As Long, j As Long
Dim min As Long, max As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ColIndex = 1
For i = 1 To LastRow
min = ws.Cells(i, 1).Value
max = ws.Cells(i, 2).Value
For j = min To max
ws.Cells(ColIndex, 3).Value = j
ColIndex = ColIndex + 1
Next j
Next i
Next ws
End Sub
edited: to have one big string in column "C" (added two lines in each code)
edited 2: added "zip3" solution for having all values listed in "C" column only
you could use either following ways
Option Explicit
Sub zips3()
'list values in column "C" in sequence from all min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
With cell.End(xlToRight).Offset(, 2).Resize(, cell.Offset(, 1).Value - cell.Value + 1)
.FormulaR1C1 = "=RC1+COLUMN()-4"
sht.Range("C" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row).Offset(1).Resize(.Columns.Count) = Application.Transpose(.Value)
.ClearContents
End With
Next cell
If IsEmpty(sht.Range("C1")) Then sht.Range("C1").Delete (xlShiftUp)
Next sht
End Sub
Sub zips()
'list values in column "C" from corresponding min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
Dim j As Long
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
For j = cell.Value To cell.Offset(, 1).Value
cell.End(xlToRight).Offset(, 1) = j
Next j
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
Sub zips2()
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
cell.End(xlToRight).Offset(, 1).Resize(, cell.Offset(, 1).Value - cell.Value + 1).FormulaR1C1 = "=RC1+COLUMN()-3"
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
A solution you can use as you like would be kinda like this:
Public Function getZIPs(rng As Range) As String
Dim myVal As Variant, str As String, i As Long, j As Long
myVal = Intersect(rng, rng.Parent.UsedRange).Value
For i = 1 To UBound(myVal)
If IsNumeric(myVal(i, 1)) And IsNumeric(myVal(i, 2)) And Len(myVal(i, 1)) > 0 And Len(myVal(i, 2)) > 0 Then
If myVal(i, 1) <= myVal(i, 2) Then
For j = myVal(i, 1) To myVal(i, 2)
str = str & ", " & j
Next
End If
End If
Next
getZIPs = Mid(str, 3)
End Function
Put this into a module and then either go for C1: =getZIPs(A1:B1) and auto fill down or directly =getZIPs(A:B) to get all numbers in one cell or use it in a sub to do it automatically.
If you have any questions, just ask :)
EDIT:
If you want it all exactly in the one-column-way, you can use this (should be fast):
Sub getMyList()
Dim sCell As Range, gCell As Range
Set gCell = ActiveSheet.[A1:B1]
Set sCell = ActiveSheet.[C1]
Dim sList As Variant
While IsNumeric(gCell(1)) And IsNumeric(gCell(2)) And Len(gCell(1)) > 0 And Len(gCell(2)) > 0
If gCell(1) = gCell(2) Then
sCell.Value = gCell(1)
Set sCell = sCell.Offset(1)
Else
sList = Evaluate("ROW(" & gCell(1) & ":" & gCell(2) & ")")
sCell.Resize(UBound(sList)).Value = sList
Set sCell = sCell.Offset(UBound(sList))
End If
Set gCell = gCell.Offset(1)
Wend
End Sub
If you have any questions, just ask ;)
I am new to VBA excel, a week old. I have little knowledge in C , with that I have created a program.
The task is that "to search a particluar Number in one excel worksheet(1) and compare in another worksheet(2), get the corrosponding coloumn data , concatinate the information into once cell on Worksheet(1) .
I tried but I can't get the process done I need a valuable suggestion how to fix my code.
My code:
Sub test1()
Dim iComp
Worksheets("BSM_STF_iO").Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(Range("A" & i).Value)
If InStr(a, "T") Then
Else
Worksheets("Tabelle1").Select
destlastrow = Range("B" & Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
b = onlyDigits(Range("B" & j).Value)
iComp = StrComp(a, b, vbBinaryCompare)
Select Case iComp
Case 0
Sheets("Tabelle1").Range(Sheets("Tabelle1").Cells(j, 3), Sheets("Tabelle1").Cells(j, 4)).Copy
Sheets("Tabelle1").Activate
erow = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Sheets("Tabelle1").Range(Cells(erow, 8), Cells(erow, 9))
Sheets("BSM_STF_iO").Activate
End Select
Next j
End If
Next i
End Sub
Function onlyDigits(s As String) As String
Dim retval As String
Dim i As Integer
retval = ""
retval = s
onlyDigits = retval
End Function
Example:
I need to put all the information from "tabelle1" worksheet information of "10000" to "BSM_STF_io" 10000.
BSM_STF_io
Tabellle1
See if this helps (I removed the .Activate/.Select parts):
Sub test1()
Dim iComp
Dim bsmWS As Worksheet, tabWS As Worksheet
Set bsmWS = Sheets("BSM_STF_iO")
Set tabWS = Sheets("Tabelle1")
LastRow = bsmWS.Range("A" & bsmWS.Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(bsmWS.Range("A" & i).Value)
If InStr(a, "T") Then
' do something?
Else
destlastrow = tabWS.Range("B" & tabWS.Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
b = onlyDigits(tabWS.Range("B" & j).Value)
iComp = StrComp(a, b, vbBinaryCompare)
Select Case iComp
Case 0
With tabWS
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Range(.Cells(j, 3), .Cells(j, 4)).Copy .Range(.Cells(erow, 8), .Cells(erow, 9))
End With 'tabWS
End Select
Next j
End If
Next i
End Sub
In your original code, sometimes you correctly gave the sheets for the range, but other times not (you should use Sheets("whatever").Rows.Count too). This will hopefully tighten it up and work for you.
I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub
I need to compare 1 worksheet (Sheet1) to another similar worksheet (Sheet2)
Sheet2 contains up to date information,which needs to be transferred to Sheet1.
However, I've run into a couple of problems:
There are some rows in Sheet1 that are not Sheet2. These need to be ignored/skipped over
There are some rows in Sheet2 that are not Sheet1. These need to be appended to the end of Sheet1
If a row exists in both Sheets, the information from the row sheet 2 needs to be transferred to the corresponding row in Sheet1
For what its worth, they have same number of columns and the column titles are exactly the same.
I've tried using a dictionary object to accomplish this but am still having all sorts of trouble.
Here's the code I have tried thus far:
Sub createDictionary()
Dim dict1, dict2 As Object
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Dim maxRows1, maxRows2 As Long
Dim i, ii, j, k As Integer
maxRows1 = Worksheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 2 To maxRows1
Dim cell1 As String
cell1 = Worksheets("Sheet1").cells(i, 2).Text & " " & Worksheets("Sheet1").cells(i, 11).Text
If Not dict1.Exists(cell1) Then
dict1.Add cell1, cell1
End If
Next i
maxRows2 = Worksheets("Sheet2").Range("A65000").End(xlUp).Row
For ii = 2 To maxRows2
Dim cell2 As String
cell2 = Worksheets("Sheet2").cells(ii, 11).Text
If Not dict2.Exists(cell2) Then
dict2.Add cell2, cell2
End If
Next ii
Dim rngSearch1, rngFound1, rngSearch2, rngFound2 As Range
For j = 2 To maxRows1
Dim Sheet1Str, Sheet2Str As String
Sheet1Str = Worksheets("Sheet1").cells(j, 2).Text & " " & Worksheets("Sheet1").cells(j, 11).Text
Sheet2Str = Worksheets("Sheet2").cells(j, 11).Text
If dict2.Exists(Sheet1Str) = False Then
'ElseIf Not dict1.Exists(Sheet2) Then
'
' Worksheets("Sheet2").Range("A" & j & ":" & "Z" & j).Copy
' Worksheets("Sheet1").Range("A" & maxRows1 + 1).Insert
' Worksheets("Sheet1").Range("A" & maxRows1 + 1).Interior.Color = RGB(255, 255, 0)
' Worksheets("Sheet1").Range("U" & maxRows1 + 1) = "INCH"
' Worksheets("Sheet1").Range("Q" & maxRows1 + 1) = "FPM"
' Worksheets("Sheet1").Range("S" & maxRows1 + 1) = "INCHES WIDE"
' Worksheets("Sheet2").Range("K" & j) = Replace(Worksheets("Sheet2").Range("K" & j), Worksheets("Sheet2").Range("B" & j), "")
' Worksheets("Sheet1").Range("K" & maxRows1 + 1) = Trim(Worksheets("Sheet2").Range("K" & j))
Else
For k = 3 To 6
If Not k = 11 Then
If Not UCase(Worksheets("Sheet1").cells(j, k).Value) = UCase(Worksheets("Sheet2").cells(j, k).Value) Then
Worksheets("Sheet1").cells(j, k).Value = Worksheets("Sheet2").cells(j, k).Value
End If
End If
Next k
End If
Next j
End Sub
Cool question, and the "does row order matter" question above lends itself nicely to using Excel's built in Range.RemoveDuplicates method. Let's get into it...
Suppose Sheet1 looks like this:
Let's say Sheet2 looks like this:
All the conditions that are described in your original question are met here. Namely:
There are rows on Sheet1 that are not on Sheet2 (row 2, for example). These will be left alone.
There are rows on Sheet2 that are not on Sheet1 (row 2, for example). These will be added to Sheet1.
There are rows that are the same on Sheet2 and Sheet1, save for a single update. (Row 7 on Sheet2, for example.) These rows will be updated on Sheet1. Of course, your situation will be different -- perhaps more columns might be updated, or they might not be in column E like my example -- you'll need to do a bit of customization here.
The following heavily-commented script walks through copying data from Sheet2 to Sheet1, then letting Excel's built-in Range.RemoveDuplicates method kill all of the rows that have been updated in column E. The script also makes use of a couple handy functions: LastRowNum and LastColNum.
Option Explicit
Sub MergeSheetTwoIntoSheetOne()
Dim Range1 As Range, Range2 As Range
Dim LastRow1 As Long, LastRow2 As Long, _
LastCol As Long
'setup - set references up-front
LastRow2 = LastRowNum(Sheet2)
LastRow1 = LastRowNum(Sheet1)
LastCol = LastColNum(Sheet1) '<~ last col the same on both sheets
'setup - identify the data block on sheet 2
With Sheet2
Set Range2 = .Range(.Cells(2, 1), .Cells(LastRow2, LastCol))
End With
'setup - identify the data block on sheet 1
With Sheet1
Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
End With
'step 1 - move the data block on sheet 1 down the sheet
' to allow room for the data block from sheet 2
Range1.Cut Destination:=Sheet1.Cells(LastRow2 + 1, 1)
'step 2 - move the data block from sheet 2 into the recently-
' cleared space on sheet 1
Range2.Copy Destination:=Sheet1.Cells(2, 1)
'step 3 - find the NEW last row on sheet 1
LastRow1 = LastRowNum(Sheet1)
'step 4 - use excel's built-in duplicate removal to
' kill all dupes on every column EXCEPT for those
' that might have been updated on sheet 2...
' in this example, Column E is where updates take place
With Sheet1
Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
Range1.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With
End Sub
'this handy function allows us to find the last row with a one-liner
Public Function LastRowNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Else
LastRowNum = 1
End If
End Function
'this handy function allows us to find the last column with a one-liner
Public Function LastColNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastColNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Else
LastColNum = 1
End If
End Function
Running this script results in the following: