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
Related
I have an excel sheet which looks like this - All the data is numerical data. The actual sheet has a lot more rows & columns in reality.
https://i.imgur.com/E2HEdXF.png
What I Want to get out of this data is something like this - For each year, I want to sort A & F based on the year's numerical data. So not one sort, but one sort per year.
I don't think there is a simple method for doing this, so I was thinking of 2 possible ways
I export the data into some database & then use SQL queries to get the output I want - I assume there must be some databases which allow you import Excel data.
or
Write a VBA program which does the following - Copy Column D & E into another place & sort based on Column E. Then Copy Column D & F into another place & sort based on Column F & so on & so forth.
I have never done VBA, but I am programmer, so I assume it wouldn't be trouble to do this.
However, I was wondering if there is some other easier way to do it or if not, which of the above two would be a better way to do it.
Copy and Sort
The following will copy the data from columns D:G as column pairs consisting of the first column and each next column, to columns A:B of newly created worksheets of the workbook containing this code and finally sort them descendingly by column B. Already existing worksheets, to be created, will previously be deleted.
Adjust the values in the constants section.
Option Explicit
Sub copyAndSort()
Const sName As String = "Sheet1"
Const sFirst As String = "D1"
Const yCols As String = "E:G"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim yrg As Range
Dim rCount As Long
Dim cCount As Long
With sws.Range(sFirst)
Dim rOff As Long: rOff = .Row - 1
Dim sCell As Range
Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub
rCount = sCell.Row - rOff
Set srg = .Resize(rCount)
Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
cCount = yrg.Columns.Count
End With
Dim sData As Variant: sData = srg.Value
ReDim Preserve sData(1 To rCount, 1 To 2)
Dim yData As Variant: yData = yrg.Value
Dim Result As Variant: ReDim Result(1 To cCount)
Dim c As Long, r As Long
For c = 1 To cCount
Result(c) = sData
For r = 1 To rCount
Result(c)(r, 2) = yData(r, c)
Next r
Next c
Erase yData
Erase sData
Dim dws As Worksheet
Dim drg As Range
Dim dName As String
Application.ScreenUpdating = False
For c = 1 To cCount
dName = Result(c)(1, 2)
On Error Resume Next
Set dws = Nothing
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
Set drg = dws.Range(dFirst).Resize(rCount, 2)
drg.Value = Result(c)
drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
Next c
wb.Save
Application.ScreenUpdating = True
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 am trying to run the LinEst function through VBA. The problem that I am having is that my X-variables are in the same column but on different worksheets.
My question: Is it possible to combine these columns from the different sheets to one range?
Below is my attempt to code but it gets stuck on the Union part. I provided my sample as well.
Thank you in advance!
Sub FM()
Dim sResult As Worksheet
Set sResult = Sheets("Result")
Dim sY As Worksheet
Set sY = Sheets("Y")
Dim sX1 As Worksheet
Set sX1 = Sheets("X1")
Dim sX2 As Worksheet
Set sX2 = Sheets("X2")
Dim sX3 As Worksheet
Set sX3 = Sheets("X3")
Dim sX4 As Worksheet
Set sX4 = Sheets("X4")
Dim x() As Variant
ReDim x(1 To 4)
x(1) = sX1.Columns("A")
x(2) = sX2.Columns("A")
x(3) = sX3.Columns("A")
x(4) = sX4.Columns("A")
Dim rY As Range
Set rY = sY.Columns("A")
sResult.Range("B2").Value = Application.WorksheetFunction.LinEst(rY, x, True, True)(1, 4)
End Sub
Sample
In your update, x is an Array of Range objects but it needs to be an array of values from each respective range. That is almost certainly the mismatch error.
Resolving that, you'll need to fix your ranges, too, because it seems unlikely that you're using 4 million rows of data (Excel 2007+ has 1048576 rows per worksheet). We can use a method from this answer to help obtain the last row with data from a given column range.
This should get your x values and put them in an array known_x and the known_y array also, which you can use in your LineEst function.
Dim known_x() 'Will contain all of your x values
Dim known_y()
Dim i As Long
Dim rng As Variant
Dim val As Variant
Dim ws As Variant
Dim obs As Long
Dim SHEET_NAMES As String 'Comma-separated list of worksheets
SHEET_NAMES = "X1,X2,X3,X4"
'## Gets the size of the array needed to contain all of the values
For Each ws In Worksheets(Split(SHEET_NAMES, ","))
With ws
obs = obs + GetLastRow(.Columns(1))
End With
Next
ReDim known_x(1 To obs)
'## Dump the values in to the array
i = 1
For Each ws In Worksheets(Split(SHEET_NAMES, ","))
With ws
Set rng = .Range("A1:A" & GetLastRow(.Columns(1)))
For Each val In rng.Value
known_x(i) = val
i = i + 1
Next
End With
Next
'## Dump your y in to an array
With Worksheets("Sheet2")
Set rng = .Range("A1:A" & GetLastRow(.Columns(1)))
known_y = Application.Transpose(rng.Value))
End With
NOTE: If you are in fact using 4 million+ observations, then I think your known_y's parameter may be wrong, because that should be the same size as known_x's in the LinEst function, and you will need to add logic to ensure the arrays are the same size, etc.
NOTE: I've no idea what you're doing with (1, 4) at the end of your LinEst function call.
I don't want to put a useless answer, but if you play a bit with it, you will find something useful. And it produces some result in B2:
Option Explicit
Sub FM()
Dim sResult As Worksheet
Set sResult = Sheets(1)
Dim sY As Worksheet
Set sY = Sheets(2)
Dim sX1 As Worksheet
Set sX1 = Sheets(3)
Dim sX2 As Worksheet
Set sX2 = Sheets(4)
Dim sX3 As Worksheet
Set sX3 = Sheets(6)
Dim sX4 As Worksheet
Set sX4 = Sheets(5)
Dim x() As Variant
ReDim x(1 To 4)
x(1) = sX1.Cells(1, 1).Value
x(2) = sX1.Cells(2, 1).Value
x(3) = sX1.Cells(3, 1).Value
x(4) = sX1.Cells(4, 1).Value
Dim rY As Range
Set rY = sY.Range(sY.Cells(1, 1), sY.Cells(5, 1))
sResult.Range("B2").Value = Application.WorksheetFunction.LinEst(rY(1, 1), x(1), True, True)
End Sub
The problem is mainly in the way you refer to Arrays and Ranges. Check all of them again and you can make a workable solution.
I am creating a VBA application that will find the text that I have entered in a certain range (Should be dynamic, in order for me to input more in the future). With that the entered texts in the range will look for the words in another sheet column:
Example:
And it will look for the words inputted in another sheet.
Dim Main as Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 as Worksheet
Set Raw2 = Sheets("Sheet2")
LookFor = Main.Range(D8:100)
Fruits = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).row
For e = lastRow To 2 Step -1
value = Raw2.Cells(e, 7).value
If Instr(value, LookFor) = 0 _
Then
Raw2.Rows(e).Delete
Honestly I am not sure how to proceed. And the mentioned code is just experiment. Desired output is to delete anything in sheet2 except for the rows that contain the words that I have inputted in the "Look for the words". Hope you can help me. Thank you.
This should do the trick :
Sub Sevpoint()
Dim Main As Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 As Worksheet
Set Raw2 = Sheets("Sheet2")
Dim LooKFoR() As Variant
Dim LastRow As Double
Dim i As Double
Dim j As Double
Dim ValRow As String
Dim DelRow As Boolean
LooKFoR = Main.Range(Main.Range("G8"), Main.Range("G" & Main.Rows.Count).End(xlUp)).Value
LastRow = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
ValRow = Raw2.Cells(i, 7).Value
DelRow = True
'MsgBox UBound(LooKFoR, 1)
For j = LBound(LooKFoR, 1) To UBound(LooKFoR, 1)
If LCase(ValRow)<>LCase(LooKFoR(j, 1)) Then
Else
DelRow = False
Exit For
End If
Next j
If DelRow Then Raw2.Rows(i).Delete
Next i
End Sub
I have a table with two rows : the first row contains the locations where the value of the second row should be pasted.
For example :
row 1 : sheet8!D2 sheet6!D2 sheet2!C5
row 2 : apple lemon pEER
So apple should be pasted in sheet 8 cell D8. Lemon should be pasted in sheet6 cell D2. The problem is that the value apple is pasted everywhere (in sheet8!D2, sheet6!D2 and sheet2!C5). How can I correct this?
Sub Sample()
Dim rng As Range
Dim Sh As String, Cl As String
Dim ws As Worksheet
Dim i As Integer
Dim Row1 As String
ncol = Range("A1:F1").Columns.Count
For i = 1 To ncol
Row1 = Range("A1:F1").Cells(1, i).Value
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
Sh = Split(Row1, "!")(0)
Cl = Split(Row1, "!")(1)
Set rng = ThisWorkbook.Sheets(Sh).Range(Cl)
rng.Value = .Range("A2").Value
End With
Next i
End Sub
There are a few issues with your code. First up its good practice to put Option Explicit at the top of each module, this will ensure variables are defined (ncol is not defined).
The following code will fix the problem although it could be tweaked in various ways. The main problem is you don't quite set the referencing ranges correctly, you move through the columns with your loop but always refer back to cell A2. Assuming your input data is on rows 1 and 2 and run from the sheet with that data this will work.
Sub SampleFixed()
Dim rng As Range
Dim Sh As String, Cl As String
Dim ws As Worksheet
Dim i As Integer, ncol As Integer
Dim Row1 As String
ncol = Range("A1:F1").Columns.Count
For i = 1 To ncol
Set ws = ActiveSheet
With ws
Row1 = .Cells(1, i).Value
If Len(Row1) > 0 Then
Sh = Split(Row1, "!")(0)
Cl = Split(Row1, "!")(1)
Set rng = ThisWorkbook.Sheets(Sh).Range(Cl)
'Here you were always refering to cell A2 not moving through the values which was the main problem.
rng.Value = .Cells(2, i).Value
End If
End With
Next i
End Sub