I have to create a Macro which lets me Concatenate two columns at a time in a given range. For example: In range C1:Z200, I want to concatenate Column C&D, E&F, G&H and so on. How do I do it. This is my current code which only concatenate first two columns..rest remains the same.
Set Range = ActiveSheet.Range("C1:Z100")
For Each c In Range
c.Select
ActiveCell.FormulaR1C1 = ActiveCell & " " & ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).Activate
Selection.Clear
ActiveCell.Offset(0, 2).Activate
Next c
Try this:
Sub Concat()
Dim i As Long, j As Long
For i = 1 To 100 'number of rows
j = 1 'reset column to 1
Do While j < 25 'max number of columns (until Column Y-Z)
j = j + 2 'start from third column (Column C)
Cells(i, j) = Cells(i, j) & " " & Cells(i, j + 1) 'concat
Cells(i, j + 1).ClearContents 'clear
Loop
Next i 'next row
End Sub
Try this:
Sub ConcatAltCellsInAltCols()
Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet11")
Dim iLC As Long: iLC = oW.Cells(1, oW.Columns.Count).End(xlToLeft).Column
Dim iLR As Long: iLR = oW.Cells(oW.Rows.Count, 3).End(xlUp).Row
Dim iC As Long
Dim iR As Long
For iR = 1 To iLR
For iC = 3 To iLC Step 2
oW.Cells(iR, iC).Value = oW.Cells(iR, iC) & oW.Cells(iR, iC + 1)
Next
Next
End Sub
Try this using a one based array for better Performance:
Code
Option Explicit
Sub Conc()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Concat") ' <== change "Concat" to your sheet name to avoid subscript error
Dim v ' variant
Dim lng As Long
Dim j As Integer ' corr.
' use one based array to get field data
v = ws.Range("C1:Z100") ' your OP range
For lng = 1 To UBound(v)
' concatenate columns C&D, E&F, G&H, ...
For j = 0 To 11
v(lng, j * 2 + 1) = v(lng, j * 2 + 1) & v(lng, j * 2 + 2)
Next j
Next lng
' write array values back (overwriting D, F, H,... with the same values)
ws.Range("C1:Z100") = v ' your OP range
End Sub
Related
Here is my current output that my VBscript is generating.
ID DESCRIPTION 1 RECURSIVE_ANALYSIS
CM-1 xxxxxxxxxxxx Issue A
Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B
Sub issue a
Sub issue b
This is following VBA code which i have designed for getting the output
Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer
iColumn = 3
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub
Here is my expected output
ID DESCRIPTION 1 RECURSIVE_ANALYSIS Issues
CM-1 xxxxxxxxxxxx Issue A Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B Sub issue a
Sub issue b
So, can someone help me to figure out to get the expected output.
Any help will be much appreciated.
Thank you
it seems you didn't show the whole story, so here's a guessing:
after your code place the following
With wksNew' reference 'wksNew' sheet
With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
.Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
.Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
.Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
.Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
End With
.Columns.AutoFit 'adjust your columns width
End With
Using Variant array is more simple.
Sub test()
Dim r As Long, c As Integer
Dim j As Integer
Dim k As Integer
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim vDB, vSplit, vR()
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
With wksSource
c = .Range("IV1").End(xlToLeft).Column
r = .Range("A65536").End(xlUp).Row
vDB = .Range("a1", .Cells(r, c))
For i = 1 To r
vSplit = Split(vDB(i, c), Chr(10))
For k = 1 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To c + 1, 1 To n)
If k = 1 Then
For j = 1 To c - 1
vR(j, n) = vDB(i, j)
Next j
vR(c, n) = vSplit(k - 1)
vR(c + 1, n) = vSplit(k)
Else
vR(c + 1, n) = vSplit(k)
End If
Next k
Next i
End With
Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub
Here is the sample of my current output which the VBscript code is generating.
[https://i.stack.imgur.com/kMpih.png] [1]:
Here is the sample of my expected output
[[1]: https://i.stack.imgur.com/StBqx.png]
Please let me know your suggestions.
Thank you
I need help with this small project. What I need to accomplished this task is the following:
I have a excel file where my macro button once clicked will read the data from a sheet1 only in column A then should throw the data to another sheet2 and move every data from the sheet1 to sheet2 and display all the data to each separate column.
here is a image of the data example. in the image every circle needs to be in its own column to the new sheet2 that is only part of the data the total of the column rows is around 900.
if need more information please let me know.
here is the code I have it copy the sheet from sheet1 to sheet2 but I need the rest to work
Sub ExportFile()
Dim strValue As String
Dim strCellNum As String
Dim x As String
x = 1
For i = 1 To 700 Step 7
strCellNum = "A" & i
strValue = Worksheets("data").Range(strCellNum).Value
Debug.Print strValue
Worksheets("NewData").Range("A" & x).Value = strValue
x = x + 1
Next
End Sub
Give this a try:
Sub DataReorganizer()
Dim s1 As Worksheet, s2 As Worksheet, N As Long, i As Long, j As Long, k As Long
Dim v As Variant
Set s1 = Sheets("Data")
Set s2 = Sheets("NewData")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 2 Step -1
If s1.Cells(i, "A").Value = "" And s1.Cells(i - 1, "A").Value = "" Then s1.Cells(i, "A").Delete shift:=xlUp
Next i
j = 1
k = 1
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = s1.Cells(i, "A").Value
If v = "" Then
j = 1
k = k + 1
Else
s2.Cells(j, k).Value = v
j = j + 1
End If
Next i
End Sub
you can try this:
Sub ExportFile()
Dim area As Range
Dim icol As Long
With Worksheets("data")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
For Each area In .Areas
icol = icol + 1
Worksheets("NewData").Cells(1, icol).Resize(area.Rows.Count).Value = area.Value
Next
End With
End With
End Sub
I'm trying to remove the blank records from a combobox with two lists.
This is my code:
Private Sub UserForm_Initialize()
Dim N As Range
Dim LastRow As Integer
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i, j As Integer
Dim location(2 To 100, 1 To 2) As String
For j = 1 To 2
For i = 2 To LastRow
If ws.Cells(i, j).Value <> vbNullString Then
location(i, j) = ws.Cells(i, j).Value
End If
Next i
Next j
PREST.List = location
End Sub
I don't know what I'm doing wrong.
You are having blanks because your 2D array is already sized with 100 rows. A simple workaround would be to first count the non-empty rows, then dimension the Array accordingly.
Dim location() As String
Dim count As Long
count = Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants).Cells.count
ReDim location(1 To count, 1 To 2)
'then continue from here to fill the array
This code will fill the combobox with your range value then will delete any empty item:
Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i As Long ', j As Integer
PREST.List = ws.Range("a1:b" & LastRow).Value
For i = PREST.ListCount - 1 To 0 Step -1
If PREST.List(i) = "" Then PREST.RemoveItem i
Next
End Sub
I tried this :
Dim location() As String
ReDim location(LastRow - 2, 1)
For j = 0 To 1
For i = 0 To LastRow - 2
If ws.Cells(i + 2, j + 1).Value <> vbNullString And ws.Cells(i + 2, j + 1).Value <> "" Then
location(i, j) = ws.Cells(i + 2, j + 1).Value
End If
Next i
Next j
PREST.List = location
which seems to work but i guess its gonna give me an error if the list is empty (lastrow = 1)
Since you say that any two cells on the same row are both either blank or with values, then you could go like follows:
Dim cell As Range
Dim i As Long, j As Long
PREST.ColumnCount = 2
With Worksheets("L_Location") '<--| reference your worksheet
With .Range("A2", .Cells(.Rows.Count,1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<--| reference its column A not empty cells from row 1 down to last not empty one
Dim location(1 To .Count, 1 To 2) As String '<--| size your array rows number to that of referenced cells
For Each cell In .Cells '<--| loop through referenced cells
i = i + 1 '<--| update array row index
For j = 1 To 2 '<--| loop through array columns
location(i, j) = cell.Offset(j -1).Value '<--| fill array
Next j
Next cell
End With
End With
PREST.List = location
I have a dataset that is dynamic, meaning N number of rows and N number of columns (groups). The first screenshot is how the data looks with 3 groups, but as I said it could be N number of groups. There can also be N number of items.
Initial Data:
The second screenshot shows how the data should look. I need to write the item name for every score (numeric value in that row). So I have to transpose the data somehow. I need to loop through the columns, but don't know how divide the groups in the loop since they have the same column headers. Only the definition and group number are always unique.
This has to be done in VBA.
Final data after looping through rows and columns and "transposing":
Thanks
EDIT: Here's the code I've tried so far, which leaves spaces between the sets and only works for the first group.
Sub transposeData()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim i As Long
Dim lastCol As Long
Dim j As Long
Dim n As Integer
Dim y As Long
Dim tempVal As Integer
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
lastCol = ws.Cells(ws2.Rows.Count, 1).End(xlUp).Row
For i = 3 To lastRow Step 1
For y = 3 To lastRow Step 1
For j = 3 To lastCol Step 1
If ws.Cells(i, j) <> vbNullString Then
tempVal = ws.Cells(i, j).Value
ws2.Cells(y, 2) = ws.Cells(i, 2).Value
ws2.Cells(y, 3) = tempVal
ws2.Cells(y, "K") = ws.Cells(2, j).Value
End If
If tempVal <> 0 And tempVal - 1 Then
y = y + 1
End If
If j = 41 Then
i = i + 1
End If
tempVal = 0
y = y
Next j
Next y
Next i
End Sub
I took advantage of Excel's Transpose ability to get this code to work based on your sample data exactly as it is shown:
Sub Transpose()
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'Sheets("Sheet1")
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1") 'Sheets("Sheet2")
ws2.Range("A1:D1").Value = Array("Name", "Value", "Test", "Defintion")
With ws1
'how many groups are there so we know how many times to transpose
'we find this out by counting the number of times "Defintion" appears
Dim lDef As Long
lDef = Application.WorksheetFunction.CountIf(.Rows(2), "Definition")
'get last row where grouped data appears
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim l As Long
For l = 3 To lRow 'loop through items
Dim rDef As Range, sFirst As String
Set rDef = .Rows(2).Find("Definition") 'find first instance of "Definition"
sFirst = rDef.Address 'get address of first occurence so we can test if we reached it again
'list Name (aka Item) (for as many rows as needed defined by how many groups * 4 (1 for each test))
With ws2
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(4 * lDef).Value = ws1.Range("A" & l)
End With
Do
'transpose values
rDef.Offset(l - 2, 1).Resize(1, 4).Copy 'uses l-2 to offset for each row throughout the loop
With ws2
'paste values (test results)
.Range("B" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).PasteSpecial xlPasteValues, Transpose:=True
'load test cases
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).Value = Application.WorksheetFunction.Transpose(Array("A", "B", "C", "D"))
'load definitions
.Range("D" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).Value = Application.WorksheetFunction.Transpose(rDef.Offset(1).Value)
End With
Set rDef = .Rows(2).FindNext(After:=rDef) 'find next definition
Loop Until rDef Is Nothing Or rDef.Address = sFirst
Next
End With
End Sub
Take a look at this macro and see what you think about it. I copied your sample set and was able to duplicate your desired results using nested for loops. Let me know if anything needs clarification.
Option Explicit
Sub customTransposing()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim startingRow As Integer
Dim startingColumn As Integer
Dim numberOfPoints As Integer
Dim numberOfEntries As Integer
Dim numberOfGroups As Integer
Dim outputRowOffset As Integer
' -------------------------------------------------------------------------------------------
' User Variables
' -------------------------------------------------------------------------------------------
startingRow = 3
startingColumn = 1
numberOfPoints = 4 ' The number of test points i.e. A B C D
numberOfEntries = 0
numberOfGroups = 3
outputRowOffset = 10
' -------------------------------------------------------------------------------------------
' Counts the number of entries in the first column
' this section could most likely be improved
Cells(startingRow, startingColumn).Select
Do Until IsEmpty(ActiveCell)
If Not IsEmpty(ActiveCell) Then
numberOfEntries = numberOfEntries + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
For j = 0 To numberOfEntries - 1
For k = 0 To numberOfGroups - 1
For i = 0 To numberOfPoints - 1
' first column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn).Value = Cells(startingRow + j, startingColumn)
' second column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 1).Value = Cells(startingRow + j, startingColumn + 2 + i + k * (numberOfGroups + 2))
' third column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 2).Value = Cells(startingRow - 1, startingColumn + 2 + i)
' fourth column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 3).Value = Cells(startingRow + j, startingColumn + 1 + k * (numberOfGroups + 2))
Next i
Next k
Next j
End Sub
How can I find a numeric number in the same cell after character. For ex After J* find number 01. I will have few rows and inside row some value will J*01 or J*08 im trying separate between character and number using instar in VBA:
Sub zz()
Dim ii As Long, z As Integer, xlastrow As Long
Dim yy As String
xlastrow = Worksheets("Sheet1").UsedRange.Rows.Count
For ii = 1 To xlastrow
yy = "J*"
z = 1
If IsNumeric(Worksheets("Sheet1").Range("B" & ii)) Then
This line separating number after J* character and pasting it to sheet2
Seprate.Find.Range("B" & ii, yy).Value = Worksheet("Sheet2").Range("A" & z)
End If
z = z + 1
Next ii
End Sub
Please try this code
' paste the values in column A.
q1w2e3r4asJ*66bvft654
1234BA
BA1234BA
xuz12354
''''' Code
Option Explicit
Sub Remove_Charecter()
Dim Last_Row As Double
Dim num As Double
Dim i As Integer
Dim j As Integer
Last_Row = Range("A65536").End(xlUp).Row
For i = 1 To Last_Row
num = 0
For j = 1 To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = (num)
Next i
'MsgBox num
End Sub
'--- Output will be
123466654
1234
1234
12354
Try the below piece of codes.
Assumption
Your data that you need to separate is in Column A
There is no blank cells in your data
Trim value will be displayed in the adjacent column i.e. Column B in subsequent cells
Code :
Dim LRow As Double
Dim i As Integer
Dim j As Integer
Dim LPosition As Integer
Dim Number As Double
LRow = Range("A1").End(xlDown).Row
For i = 1 To LRow
Number = 0
LPosition = InStr(1, Cells(i, 1), "J*")
For j = (LPosition + 2) To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = Number
Next i