I have a piece of code to copy some info out of a random number of sheets (from the 7th sheet and on). as follows
Sub Controle()
Dim sh As Worksheet, N As Long
Dim i As Long, M As Long
N = Sheets.Count
M = 1
For i = 7 To N
Sheets(i).Range("E2").Copy
Sheets("Controle tabel").Cells(1, M).PasteSpecial (xlValues)
Sheets("Controle tabel").Cells(1, M).PasteSpecial (xlFormats)
M = M + 1
Next i
End Sub
I also want to count the amount on values in column A, I tried to add this
Sheets(i).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
but it won't run, I think I need to add how where to paste it, since it has to come under the names pasted using the code but I have no clue how this can ben done. I added a new variable L to make a list just as with M
Sheets(i).Range("A:A").Cells(1, L).SpecialCells(xlCellTypeConstants).Count
But it still won't run I think I might be using the wrong way to count no null (since you also have COUNTA, but since we don't know the names of the sheets this is hard I think)
So it also has to loop all the sheets after the 7th and count the not empty cells in column A
Guessing a little, but this?
Sub Controle()
Dim sh As Worksheet, N As Long
Dim i As Long, M As Long, L As Long
N = Sheets.Count
M = 1
For i = 7 To N
Sheets(i).Range("E2").Copy
Sheets("Controle tabel").Cells(1, M).PasteSpecial (xlValues)
Sheets("Controle tabel").Cells(1, M).PasteSpecial (xlFormats)
Sheets("Controle tabel").Cells(1, M + 1) = Sheets(i).Range("A:A").SpecialCells(xlCellTypeConstants).Count
M = M + 2
Next i
End Sub
Try this once -
Dim sh As Worksheet, N, i, m, lastrow, nullcount As Long
N = Sheets.Count
For i = 7 To N
lastrow = Sheets("Controle tabel").Range("A500000").End(xlUp).Row + 1
Sheets("Controle tabel").Range("A" & lastrow).Value = Sheets(i).Range("E2").Value
Next i
On Error Resume Next
nullcount = Application.WorksheetFunction.CountIf(Sheets("Controle tabel").Range("A:A"), "NULL")
Sheets("Controle tabel").Range("A" & lastrow).Value = nullcount
Related
I have a column "F" in workbook1 containing some values (obtained after using some excel formulas to extract and concatenate from other columns) like
blah-rd1
blah-rd5
blah-rd6
blah-rd48do I want to do this
blah-rd100
etc
I have another column "D" in workbook2 containing values like
rndm-blah-rd1_sgjgs
hjdf-blah-rd5_cnnv
sdfhjdf-blah-rd100_cfdnnv
ect
Basically "Blah-rdxx" is always present alongwith other strings in D column of workbook2
Now, what I want to do is -
If value in D column of workbook2 contains value of F column of workbook1 Then
copy corresponding value of S column of workbook2 in H column of workbook1 (5th column)
This is where I have reached so far but it doesnt copy anything probably coz there is some problem and the outer loop is not iterating, I tried following solution Nested For Next Loops: Outer loop not iterating and added n counter but still outer loop doesn't iterate -
Sub findandcopy()
Dim r As Range
Dim f As Range
Dim i As Long
Dim j As Long
Dim w1 As Worksheet
Dim w2 As Worksheet
Dim n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
w2.Cells(i, 2).Copy (w2.Cells(j, 5))
Exit For
n = n + 1
End If
Next j
Next i
End Sub
Try this
Option Explicit
Public Sub FindAndCopy()
Const F = "F"
Const D = "D"
Const H = 2
Const S = 15
Dim ws1 As Worksheet: Set ws1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Workbooks("Book2.xlsm").Worksheets("Sheet1")
Dim lr1 As Long: lr1 = ws1.Cells(ws1.Rows.Count, F).End(xlUp).Row
Dim lr2 As Long: lr2 = ws2.Cells(ws2.Rows.Count, D).End(xlUp).Row
Dim itm1 As Range, itm2 As Range
Application.ScreenUpdating = False
For Each itm2 In ws2.Range(ws2.Cells(1, D), ws2.Cells(lr2, D)) 'Book2
For Each itm1 In ws1.Range(ws1.Cells(1, F), ws1.Cells(lr1, F)) 'Book1
If Not IsError(itm1) And Not IsError(itm2) Then
If InStr(1, itm2.Value2, itm1.Value2) > 0 Then
itm1.Offset(, H).Formula = itm2.Offset(, S).Formula 'Book1.H = Book2.S
Exit For
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub
The original code, with explanations of functional issues:
Sub findandcopy()
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n 'for each used cell in w1.colA
'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
w2.Cells(i, 2).Copy (w2.Cells(i, 5))
Exit For 'this exits the inner For loop
n = n + 1 'this would jump over the next cell(s) in w1, but never executes
End If
Next j
Next i
End Sub
The missing indentation makes it hard to follow
There are unused variables (r, f), and w1 / w2 names can mean Workbook, or Worksheet
"Option Explicit" should be used at the top of every module
The code doesn't handle cells with errors
#N/A, #VALUE!, #REF!, #DIV/0!, #NUM!, #NAME?, or #NULL!
If you'd like a more detailed review of the code, once it's fixed you can post it on Code Review
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 am brand new to VBA and learning on my own. I want to make a code in which I type a number in a cell (E4, last worksheet) and when run the macro, go and search for all worksheets that match that number in cell F2 and then for each worksheet that match the number, copy a range (which is a column) and then paste all columns in a new worksheet (added at the end). I have try some of the code below in different ways and sometimes work and sometimes does not. Among other problems, the problem with the code below is that when it works it is only copying one column from one finding. If there is a better, more elegant way to write this ( and make it work) your help is appreciated.
Sub abc()
Dim wscount As Integer
Dim wb As Workbook
Set wb = ActiveWorkbook
wscount = wb.Worksheets.Count
k = 1
j = 1
If Worksheets(k).Range("F2").Value = Worksheets(wscount).Range("E4").Value Then
Worksheets(wscount + 1).Range(Cells(1, 1 + j), Cells(100, 1 + j)).Value = Worksheets(k).Range("F1:F100").Value
Worksheets(wscount + 1).Range(Cells(1, 1 + j), Cells(100, 1 + j)) = Worksheets(k).Range("F1:F100").Value
j = j + 1
End If
End Sub
You were not adding a new sheet and you were not looping among the sheets. Here's a way to do it:
Sub abc()
Dim wscount As Integer: wscount = Worksheets.Count
Dim j As Long, k As Long
Worksheets.Add After:=Worksheets(wscount)
For k = 1 To wscount - 1
If Worksheets(k).Range("F2").value = Worksheets(wscount).Range("E4").value Then
j = j + 1
Worksheets(wscount + 1).Columns(j).value = Worksheets(k).Columns("F").value
End If
Next
End Sub
I am attempting to create a VBA code that will paste a formula to Variable Range of both columns and cells. I have the start of a code I thought I could modify, but I have been unsuccessful.
I have a sheet (see image) that has a variable range between A2 & ? I need to paste into the area C3 to the end of rows and columns a formula that will take the value in B and divide it by the number of columns. I thought I had a start but I am failing.
Please assist. "Start" Code Follows
Sub QtyByWks()
Dim M As Long, N As Long, i As Long, x As Long, j As Long
M = Sheet10.Cells(1, Columns.count).End(xlToLeft).Column
N = Sheet10.Cells(Rows.count, "A").End(xlUp).Row
j = 3
For x = 1 To M
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Cells(j, "C").Value = Cells(i, "B").Value
j = j + 2
End If
Next i
Next x
End Sub
Also note, Both Rows and Columns are Variable via an additional VBA [Capture of Worksheet]
Thanks in advance for the assist
Hard to tell what sort of errors/issues you had with your code since you haven't provided much info. Either way, I'll take a stab at adjusting what you provided to do what I THINK you're trying to do:
Sub QtyByWks()
Dim M As Long, N As Long, i As Long, x As Long, j As Long
' Changed the formula to check row 2 instead of one, as per your screenshot.
M = Sheet1.Cells(2, Columns.count).End(xlToLeft).Column
N = Sheet1.Cells(Rows.count, "A").End(xlUp).Row
j = 3
'Replaced the x loop with a j loop that increments by 2.
For j = 3 To N Step 2
'Had the i loop start from 3 instead of 1
For i = 3 To M
If Cells(j, "B").Value > 0 Then
'Divided the "B" value by the number of columns M, which is what it sounds like you were going for in your description.
Cells(j, i).Value = Cells(j, "B").Value / (M - 2)
End If
Next i
Next j
End Sub
Obviously the code is working on the assumption that the Columns and Rows variables are returning expected values.
I've seen some similar posts but not quite what I need or could understand to solve my simple problem.
I have hundreds of rows of data that I'd like to transform into columns. Original data is like so with two empty rows between and the sets of related data can vary in length:
9
8
7
6
5
4
3
2
1
J
I
H
G
F
E
D
C
B
A
I'd like to be able to reverse the order of each set and then transpose them in columns going down another row for each data set like so:
1 2 3 4 5 6 7 8 9
A B C D E F G H I J
I had some success with the first part using a simple formula =OFFSET($A$2,COUNTA(A:A)-ROW(),0) because I wasn't sure how to do it in VBA.
The code I'm using to grab all the data and then transpose, I'm having trouble getting it to go down a row for each unique data set. Here's the code I'm trying to use, but it doesn't seem to work and just start running down the worksheet until the macro craps out.
Sub TransposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheets("Output").Range("A3:A10002")
Set OutRange = Sheets("Output").Range("H2:NTR2")
For i = 1 To 10000 Step 1
OutRange.Cells(1, i) = InRange.Cells(i, 1)
ActiveCell.Offset(1, 0).Select
Next i
End Sub
I'm sure there's something obvious and simple I'm missing but alas I'm still a noob in training. Any suggestions would be greatly appreciated.
Assuming your data is at column A, please try the following using sort then pastespecial with transpose: (please change sheets name according to your own)
Sub sortNtranspose()
Dim r As Integer
Dim i As Integer
Dim j As Integer
Dim rn As Range
r = Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To r
Set rn = Range(Cells(i, 1), Cells(Cells(i, 1).End(xlDown).Row, 1))
rn.Sort key1:=Cells(i, 1), order1:=xlAscending, Header:=xlNo
Set rn = Range(Cells(i + 1, 1), Cells(Cells(i, 1).End(xlDown).Row, 1))
rn.Copy
Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Do While Not IsEmpty(Cells(i, 1))
If IsEmpty(Cells(i, 2)) Then
Cells(i, 2).EntireRow.Delete
Else:
i = i + 1
End If
Loop
r = Sheets("Sheet1").UsedRange.Rows.Count
If j >= r Then
Exit Sub
End If
j = Cells(i, 1).End(xlDown).Row
i = j - 1
Next i
End Sub
This code assumes that your data are constants, and uses VBA's wonderful SpecialCells property to break out each chunk in column 1. It also uses an array, which is much faster than looping through cells:
Sub TransposeColumnSections()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim ColumnConstants As Excel.Range
Dim i As Long
Dim ColumnArea As Excel.Range
Dim AreaRowsCount As Long
Dim ReversedConstants() As Variant
Dim j As Long
Set ws = ActiveSheet
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set ColumnConstants = .Columns(1).SpecialCells(xlCellTypeConstants)
For i = 1 To ColumnConstants.Areas.Count
Set ColumnArea = ColumnConstants.Areas(i)
AreaRowsCount = ColumnArea.Rows.Count
ReDim ReversedConstants(1 To AreaRowsCount)
For j = AreaRowsCount To 1 Step -1
ReversedConstants(AreaRowsCount - (j - 1)) = ColumnArea(j).Value
Next j
.Cells(i, 2).Resize(1, AreaRowsCount) = ReversedConstants
Next i
.Columns(1).Delete
End With
End Sub