I am having a excel with one column that has got information regarding tender. Each cell will have a value like
Column: Nokia([Mode1.Number],OLD)
Column: Motorola([Mode1.Number],OLD)
Column: Motorola([Mode2.Number],NEW)
Column: Motorola([Mode3.Number],OLD)
Column: Samsung([Mode2.Number],NEW)
I need to create 2 excel out of this. One should 've all the information of the OLD and the second excel should've all the information of NEW.
So my output excel should contain
First Excel
Nokia([Model1.Number])
Motorola([Mode1.Number])
Motorola([Mode3.Number])
Second Excel
Motorola([Mode2.Number])
Samsung([Mode2.Number])
Kindly help me.. Thanks in advance..
Highlight the cells containing the data you want to copy and then run this code
sub copystuff
dim r as range
dim tn as range
im to as range
dim wsNewTarget as worksheet
dim wsOldTarget as worksheet
dim wsSource as worksheet
set wsSource = activesheet
set wsNewtarget = activeworkbook.worksheets.add
set wsoldtarget = activeworkbook.worksheets.add
set tn = wsnewtarget.range("a1")
set to =wsoldtarget.range("a1")
for each r in wssource.selection
if imstr(r,"NEW")>0 then
tn=r
set tn = tn.offset(1,0)
else
to=r
set to = to.offset(1,0)
end if
next r
end sub
Sub SplitOldNew()
Dim InRange As Range, OldRange As Range, NewRange As Range
Dim Idx As Integer
Set InRange = Selection ' select all cells to be split
Set OldRange = Worksheets("OLD").[A1] ' choose appropriate target entry points
Set NewRange = Worksheets("NEW").[A1] ' ...
Idx = 1 ' loop counter
Do While InRange(Idx, 1) <> ""
If InStr(1, InRange(Idx, 1), "OLD") <> 0 Then
DBInsert OldRange, InRange(Idx, 1)
Else
DBInsert NewRange, InRange(Idx, 1)
End If
Idx = Idx + 1
Loop
End Sub
Sub DBInsert(intoRange As Range, Arg As String)
Dim Idx As Integer
Idx = 1 ' loop counter
Do While intoRange(Idx, 1) <> "" ' find first blank row
Idx = Idx + 1
Loop
intoRange(Idx, 1) = Arg ' write out
End Sub
Related
I'm new in VBA and actually don't know how to deal with that task. Maybe you can help me.
I have two tables in two sheets.
Table from sheet 1 is updated daily.
What I need to do is check if any value in column A (sheet 1) is in column A (sheet 2).
If yes, then do nothing.
If no, then copy whole row into the table in sheet 2.
Basing on google results I started to write some code but I stuck.
Dim source As Worksheet
Dim finaltbl As Worksheet
Dim rngsource As Range
Dim rngfinaltbl As Range
'Set Workbook
Set source = ThisWorkbook.Worksheets("Sheet 1")
Set finaltbl = ThisWorkbook.Worksheets("Sheet 2")
'Set Column
Set rngsource = source.Columns("A")
Set rngfinaltbl = finaltbl.Columns("A")
I assume that next I need to write some loop but I really don't know how it works.
Update Worksheet With Missing (Unique) Rows (Dictionary)
Adjust the values in the constants section.
Sub UpdateData()
' Source
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A2"
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A2"
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
Dim drg As Range
Dim dCell As Range
Dim drCount As Long
' Reference the destination data range.
With dws.Range(dFirstCellAddress)
Set dCell = .Resize(dws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If dCell Is Nothing Then Exit Sub ' no data in column range
drCount = dCell.Row - .Row + 1
Set drg = .Resize(drCount)
End With
Dim Data As Variant
' Write the values from the destination range to an array.
If drCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = drg.Value
Else
Data = drg.Value
End If
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
Dim dr As Long
For dr = 1 To drCount
Key = Data(dr, 1)
If Not IsError(Key) Then ' exclude errors
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next dr
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
Dim srg As Range
Dim sCell As Range
Dim srCount As Long
' Reference the source data range.
With sws.Range(sFirstCellAddress)
Set sCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub ' no data in column range
srCount = sCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
' Write the values from the source range to an array.
If srCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
Else
Data = srg.Value
End If
Dim surg As Range
Dim sr As Long
' Loop through the source values...
For sr = 1 To srCount
Key = Data(sr, 1)
If Not IsError(Key) Then ' exclude errors
If Len(Key) > 0 Then ' exclude blanks
If Not dict.Exists(Key) Then ' if source value doesn't exist...
dict(Key) = Empty ' ... add it (to the dictionary)...
If surg Is Nothing Then ' and combine the cell into a range.
Set surg = srg.Cells(sr)
Else
Set surg = Union(surg, srg.Cells(sr))
End If
End If
End If
End If
Next sr
' Copy all source rows in one go below ('.Offset(1)') the last cell.
If Not surg Is Nothing Then
surg.EntireRow.Copy dCell.Offset(1).EntireRow
End If
MsgBox "Data updated.", vbInformation
End Sub
No you don't need a loop. You need the Find function for a Range
See Documentation for Find Method (Excel)
also Excel VBA Find A Complete Guide
I'm having a problem with my excel program. I want to make the names and the telephone numbers to paste at the other sheet, but names must be sorted randomly and the phone numbers must be the same. For Example at the first sheet i have Kalin Kalinov +22222222 and Martin Martinov +99119911 and at the other sheet after the copy paste action they must be like Martin Martinov +99119911 and Kalin Kalinov +22222222.
Sub GenerateNames()
Dim ssheet1 As Worksheet
Dim rnsheet As Worksheet
Set ssheet1 = ThisWorkbook.Sheets("Sheet1")
Set rnsheet = ThisWorkbook.Sheets("RandomNames")
ssheet1.Range("A3:A70").Copy rnsheet.Range("A3:A70")
ssheet1.Range("B3:B70").Copy rnsheet.Range("B3:B70")
End Sub
Add something like this, and apply it either on the source sheet or on the target sheet:
Range("C3").Formula = "=RAND()"
Range("C3").AutoFill Destination:=Range("C3:C70")
Range("A:C").Sort key1:=Range("C3"), order1:=xlAscending, Header:=xlYes
It creates a column of random values, used for sorting. You might want to delete it afterwards.
Sub randomName()
Dim ws As String, ws2 As String, rg As Range, rg2 As Range
Dim DataRange As Variant, i As Integer
Dim n As Integer, tmp As String
Dim nData As Integer
'== set by user
nData = 70 '== data size
ws = "sheet1": ws2 = "RandomNames" '== sheets name
Set rg = Sheets(ws).Cells(3, 1): Set rg2 = Sheets(ws2).Cells(3, 1) '=range with start row
'== Run
rg2.Resize(nData, 2).Value = rg.Resize(nData, 2).Value
DataRange = rg.Resize(nData).Value
For i = 1 To UBound(DataRange)
n = CLng(Rnd(i) * Second(Now) * 100) Mod UBound(DataRange) + 1
If i <> n Then tmp = DataRange(n, 1): DataRange(n, 1) = DataRange(i, 1): DataRange(i, 1) = tmp
Next i
rg2.Resize(nData) = DataRange: Set rg = Nothing: Set rg2 = Nothing
End Sub
I found this piece of code which does 99% what i need.
Procedure description: In my workbook there is one SQL Sheet with named columns, based on the Column Header I have to loop through all other sheets (variable from 10 to 50 sheets) in the workbook where the Column Header has the identical name, all columns from the source SQL Sheet are copied to the goal sheets. In the goal sheets the column header consist of 4 rows, in the source the column header has only 1 row.
Problem-1: How can I copy the column without the header and paste the content with an offset of 4 rows.
Problem-2: How can I copy only the real used range, the workbook is getting huge.
Code-Sample:
Sub Test()
Dim Sh2Cell As Range
Dim Sh3Cell As Range
Dim ShQuelleTitle As Range
Dim ShZielTitle As Range
'Here we loop through the Range where the Title Columns for source and goal sheet are stored
'The columns in the Source Sheet do not have the same order as in the Goal Sheet
Set ShQuelleTitle = Sheets("SQL").Range("SQL_Titel")
Set ShZielTitle = Sheets("Ziel").Range("Ziel_Titel")
For Each Sh2Cell In ShQuelleTitle
For Each Sh3Cell In ShZielTitle
If Sh2Cell = Sh3Cell Then
Sh2Cell.EntireColumn.Copy Sh3Cell.EntireColumn
' Problem-1 is: in the goal sheet the copy range has to be shifted 4 rows down because
' i have different column title structure which has to be maintained (with this goal
' sheet there happens a txt-export from another external developer.
' Problem-2 is: how can i only copy and paste cells with content - the worksheets are getting
' huge on file size if the copy range has some weird formatting
End If
Next
Next
End Sub
Sub UpDateData()
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim wData As Worksheet
Dim Process(1 To 2) As String
Dim iProc As Long
Dim Dict As Object
Process(1) = "SQL"
Process(2) = "ACCOUNT ACC STD"
Set wData = Sheets("ACCOUNT")
Set Dict = CreateObject("Scripting.Dictionary")
With wData
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Len(.Cells(1, j)) > 0 Then Dict.Add LCase$(.Cells(1, j)), j
Next j
End With
i = 5
For iProc = 1 To 2
With Sheets(Process(iProc))
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Dict.exists(LCase$(.Cells(1, j))) Then
k = Dict(LCase$(.Cells(1, j)))
.Cells(2, j).Resize(n - 1).Copy wData.Cells(i, k).Resize(n - 1)
End If
Next j
End With
i = i + n - 1
Next iProc
End Sub
You can loop through range as if it was an array:
Dim srcRng As Range
dim trgRng As Range
Dim iii As Long
Dim jjj As Long
Dim iRowStart As Long
Set srcRng = Sheets("your_source_sheet").Range("source_range")
Set trgRng = Sheets("your_target_sheet").Range("target_range")
iRowStart = 4
For iii = iRowStart To UBound(srcRng(), 1)
For jjj = 1 To UBound(srcRng(), 2) ' <~~ necessary only if you were dealing with more than one column
With trgRng
If srcRng(iii, jjj).Value <> "" Then .Cells(.Rows.Count + 1, jjj).Value = srcRng(iii, jjj).Value
End With
Next jjj
Next iii
Set srcRng = Nothing
Set trgRng = Nothing
I haven't tested the code, but it should do the trick
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(4, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
I have 3 worksheets(base) and a master worksheet (master) to compare with.
For each base worksheet, I need to compare the string value in each row for Col H (e.g.) to each row in master worksheet for Col G (e.g.). If the string value does not exist in the whole col G, the row in the base worksheet must be copied over to the master worksheet.
TIA!
I think its easy enough the use the worksheet function Match which will error if the items doesn't exist so we handle the error. Here's my answer:
Sub MyCompare()
Dim wksMaster As Worksheet
Dim wksBases(2) As Worksheet
Dim wksBase As Variant
Dim intRowCountBase As Integer
Dim intRowCountMaster As Integer
Dim rngCell As Range
Dim rngMasterColG As Range
Dim intMatch As Integer
'set up sheet vaiables
Set wksMaster = ActiveWorkbook.Worksheets("Master")
Set wksBases(0) = ActiveWorkbook.Worksheets("Base1")
Set wksBases(1) = ActiveWorkbook.Worksheets("Base2")
Set wksBases(2) = ActiveWorkbook.Worksheets("Base3")
'get the range of the master sheet col G
intRowCountMaster = wksMaster.UsedRange.Rows.Count
Set rngMasterColG = wksMaster.Range(wksMaster.Cells(1, 7), wksMaster.Cells(intRowCountMaster, 7))
'Loop through the base sheets
For Each wksBase In wksBases
intRowCountBase = wksBase.UsedRange.Rows.Count
'Loop through the cells in col H of the base sheet
For Each rngCell In wksBase.Range(wksBase.Cells(1, 8), wksBase.Cells(intRowCountBase, 8))
If rngCell.Value <> "" Then 'only do something if there is a value in the base sheet
On Error Resume Next
'the match value will error if the item doesn't exist
intMatch = Application.WorksheetFunction.Match(rngCell.Value, rngMasterColG, 0)
If Err.Number > 0 Then ' ie there is no match
On Error GoTo 0
intRowCountMaster = intRowCountMaster + 1
'put the item on the master sheet
wksMaster.Cells(intRowCountMaster, 7).Value = rngCell.Value
'reset the master range
Set rngMasterColG = wksMaster.Range(wksMaster.Cells(1, 7), wksMaster.Cells(intRowCountMaster, 7))
End If
End If
Next rngCell
Next wksBase
End Sub
I recently used code from a post by #LondonRob, which allows the format of a cell to be carried over with the containing data when using VLOOKUP.
Original question - Vlookup to copy color of a cell - Excel VBA
This is great and works for the majority of values. Unfortunately some values can't have the format carried across and I receive the error:
Run-time error "13": Data mismatch
I have taken out all empty cells and by trial and error taken out any formula errors and corrected misspellings. There are still a few cells bring this message up when trying to run the macro.
I can't see any errors in the data, and the occurrence of this error in cells appears to be almost random. The data set is also huge, so even finding all the problematic cells is proving difficult (I have located a few).
I would have commented on the thread, but I don't have the reputation at this point.
The coding used is (though in my module I took out the first 6 lines) -
Option Explicit
' By StackOverflow user LondonRob
' See https://stackoverflow.com/questions/22151426/vlookup-to-copy-color-of-a-cell-excel-vba
Public Sub formatSelectionByLookup()
' Select the range you'd like to format then
' run this macro
copyLookupFormatting Selection
End Sub
Private Sub copyLookupFormatting(destRange As Range)
' Take each cell in destRange and copy the formatting
' from the destination cell (either itself or
' the vlookup target if the cell is a vlookup)
Dim destCell As Range
Dim srcCell As Range
For Each destCell In destRange
Set srcCell = getDestCell(destCell)
copyFormatting destCell, srcCell
Next destCell
End Sub
Private Sub copyFormatting(destCell As Range, srcCell As Range)
' Copy the formatting of srcCell into destCell
' This can be extended to include, e.g. borders
destCell.Font.Color = srcCell.Font.Color
destCell.Font.Bold = srcCell.Font.Bold
destCell.Font.Size = srcCell.Font.Size
destCell.Interior.Color = srcCell.Interior.Color
End Sub
Private Function getDestCell(fromCell As Range) As Range
' If fromCell is a vlookup, return the cell
' pointed at by the vlookup. Otherwise return the
' cell itself.
Dim srcColNum As Integer
Dim srcRowNum As Integer
Dim srcRange As Range
Dim srcCol As Range
srcColNum = extractLookupColNum(fromCell)
Set srcRange = extractDestRange(fromCell)
Set srcCol = getNthColumn(srcRange, srcColNum)
srcRowNum = Application.Match(fromCell.Value, srcCol, 0)
Set getDestCell = srcRange.Cells(srcRowNum, srcColNum)
End Function
Private Function extractDestRange(fromCell As Range) As Range
' Get the destination range of a vlookup in the formulat
' of fromCell. Returns fromCell itself if no vlookup is
' detected.
Dim fromFormula As String
Dim startPos As Integer
Dim endPos As Integer
Dim destAddr As String
fromFormula = fromCell.Formula
If Left(fromFormula, 9) = "=VLOOKUP(" Then
startPos = InStr(fromFormula, ",") + 1
endPos = InStr(startPos, fromFormula, ",")
destAddr = Trim(Mid(fromFormula, startPos, endPos - startPos))
Else
destAddr = fromCell.Address
End If
Set extractDestRange = fromCell.Parent.Range(destAddr)
End Function
Private Function extractLookupColNum(fromCell As Range) As Integer
' If fromCell contains a vlookup, return the number of the
' column requested by the vlookup. Otherwise return 1
Dim fromFormula As String
Dim startPos As Integer
Dim endPos As Integer
Dim colNumber As String
fromFormula = fromCell.Formula
If Left(fromFormula, 9) = "=VLOOKUP(" Then
startPos = InStr(InStr(fromFormula, ",") + 1, fromFormula, ",") + 1
endPos = InStr(startPos, fromFormula, ",")
If endPos < startPos Then
endPos = InStr(startPos, fromFormula, ")")
End If
colNumber = Trim(Mid(fromFormula, startPos, endPos - startPos))
Else
colNumber = 1
End If
extractLookupColNum = colNumber
End Function
Private Function getNthColumn(fromRange As Range, n As Integer) As Range
' Get the Nth column from fromRange
Dim startCell As Range
Dim endCell As Range
Set startCell = fromRange(1).Offset(0, n - 1)
Set endCell = startCell.End(xlDown)
Set getNthColumn = Range(startCell, endCell)
End Function
Thanks
There's a lot of code there, so it's difficult to say what the exact issue might be.
Try this version:
Sub tester()
Dim c As Range
If TypeName(Selection)<>"Range" Then Exit Sub
For Each c In Selection
CopySourceFormats c
Next c
End Sub
'If the passed cell has a VLOOKUP formula,
' extract the arguments and find the source of the return value.
'Copy formatting from that cell to the cell with the formula
Sub CopySourceFormats(c As Range)
Dim arr, v, rng As Range, col As Long, f As String
Dim m, fs As Font, fd As Font, rngSrc As Range
'skip any unwanted cells
f = c.Formula
If Not f Like "=VLOOKUP(*" Then Exit Sub
If IsError(c.Value) Then Exit Sub 'no "source" cell to find
'Extract just the arguments and create an array
' (assumes no arguments contain a comma:
' would need better parsing otherwise)
f = Replace(f, "=VLOOKUP(", "")
f = Left(f, Len(f) - 1)
arr = Split(f, ",")
v = c.Parent.Evaluate(arr(0)) 'get lookup value
Set rng = Evaluate(arr(1)) 'source table (could be on another sheet)
col = CLng(arr(2)) 'column number in lookup table
'Debug.Print v, rng.Address(), col
'Try to match the value in the first column of the lookup table
m = Application.Match(v, rng.Columns(1), 0)
'Got a match? Copy formatting for the "source" cell
If Not IsError(m) Then
Set rngSrc = rng.Cells(m, col)
Set fs = rngSrc.Font
Set fd = c.Font
'copy formatting: add/subtract properties to suit...
fd.Size = fs.Size
fd.Color = fs.Color
fd.Bold = fs.Bold
c.Interior.ColorIndex = rngSrc.Interior.ColorIndex
End If
End Sub