Wow. Actually this works well. Very big thank you for your help delving this problem.
Posts by 7absinth
-
-
Nice try pike . But this is similar that I have made before without rules. But now there is the rules you didn't noticed.
The first rule as you see is :
1) 'Check if certain selected cell through loop in column B:B starts with "33". If yes (>0) then copy this cell to ws2 in k row
And the second one is (if the first rule is triggered)
2) 'Check if certain selected cell through loop in column A:A starts with "UK". If yes (>0) then copy entire to ws2 in k row
Both are commented in the code. You can check the format (M1:N9) that are marked in yellow to see the format how it should to look.
-
Hello everybody.
I am struggling with the solution to copy out specific cells sequentially through the cells from 2 columns, but still no luck to complete it. Currently it do nothing.
The format that I want:
Code
Display MoreSub test() Dim ws, ws2 As Worksheet, v As Variant, k As Long, i Application.DisplayAlerts = False Application.ScreenUpdating = False On Error Resume Next Sheets("NewSheet").Delete k = 1 Sheets.Add.Name = "NewSheet" Set ws = Worksheets("Details for we 200522") Set ws2 = Worksheets("NewSheet") ws.Activate For Each xcell In Intersect(Range("B:B"), ws.UsedRange) 'Check if certain selected cell through loop starts with "33". If yes (>0) then copy this cell to ws2 in k row i = xcell.Value If InStr(i, Left(i, 2)) > 0 Then i.Copy ws2.Cells(k, 1) k = k + 1 'to keep the format continue to check A:A column to proceed information copying For Each ycell In Intersect(Range("A:A"), ws.UsedRange) 'Check if certain selected cell through loop starts with "UK". If yes (>0) then copy entire row to ws2 in k row j = ycell.Value If InStr(j, Left(j, 2)) > 0 Then i.Copy.EntireRow ws2.Cells(k, 1) k = k + 1 End If Next ycell End If Next xcell 'Delete unnecessary columns to make the needed format ws2.Range(Cells(1, 2), Cells(1, 7)).EntireColumn.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
Where is the problem?
See below the file what I want to get.
-
Wow. I didn't expect it will be so complicated script. However I found an error in extraction sheet, where B values with 0 in the front are disappeared:
0278 278 FALSE 0057 57 FALSE 0025 25 FALSE 0127 127 FALSE 0306 306 FALSE 0051 51 FALSE 0217 217 FALSE 0963 963 FALSE
I formatted entire sheet as text and after that B column values were shown correctly.Thanks a lot!
-
This is very simple, but I am still struggling how to write the script correctly. So I have a table that have information in multiple columns in following layout
A B C B C B C 10119794 5281 0 0278 1 2392 2 1066246 5281 10 0278 24 2392 10 1047076 5281 15 0278 9 2392 15 The goal is find the correct VBA routine to cut/extract data from columns to rows in following layout, keeping only table title in another sheet:
A B C 10119794 5281 0 1066246 5281 10 1047076 5281 15 BC10119794 0278 1 1066246 0278 24 1047076 0278 9 BC10119794 2392 2 1066246 2392 10 1047076 2392 15 Maybe there are the solution?
Very appreciate any help.
Thanks
-
Thanks a lot, Barry. I tested it and just noticed small errors under:
But overall works well. Also needed to change this part too:
because it doesnt delete colors when sheet list is reduced. Again thanks so much for your time. I will subscribe to your profile and like your post.
God bless you.
-
you can attach a sample workbook. that has your current code. I see what you want now .... give me a sample workbook to work with will make assisting easier.
Sample added.
-
I have a following code that list and link all my worksheets in one long list. Now I come to the fact that this linked list is too long to me and I wonder if it's possible to split long linked lists into columns. I have seen separate codes that just copy out the values and split list into columns but in my case I want these cells linked too. So I am stuck and no idea how to implement code in this macro. Below is my macro.
Code
Display MorePrivate Sub Worksheet_Activate() Dim xSheet As Worksheet, x As Long, xName As Name Application.ScreenUpdating = False Me.Move Before:=Sheets(1) x = 1 With Me .Columns(1).ClearContents .Cells(1, 1) = "INDEX" .Cells(1, 1).Name = "INDEX" .Cells(1, 1).Font.Bold = 1 .Cells(1, 1).Borders(xlEdgeBottom).LineStyle = xlDouble End With For Each xSheet In Worksheets If xSheet.Name <> Me.Name Then x = x + 1 With xSheet ' Uncomment for the first use and launch. The comment again. ' .Rows("1:1").Insert Shift:=xlUp ' .Rows("1:1").Clear .Range("A1").Name = "_" & .Name .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", SubAddress:="INDEX", TextToDisplay:="Back to Index" .Range("A1").Font.ColorIndex = xlAutomatic .Range("A1").Font.Bold = 1 Me.Hyperlinks.Add Anchor:=Me.Cells(x, 1), Address:="", SubAddress:="_" & .Name, TextToDisplay:=.Name Me.Cells(x, 1).Font.Underline = xlUnderlineStyleNone Me.Cells(x, 1).Font.ColorIndex = xlAutomatic Me.Cells(x, 1).Font.Bold = 1 End With End If ' Me.Columns(1).AutoFit Next xSheet Application.ScreenUpdating = True End Sub
How to do that?
-
Its works!! Nice shot! Thanks a lot! I liked your post.
-
Try:
Code
Display MoreSub AddListValuesInSheets() Dim xRg As Range, sh As Worksheet Set dbrange = Application.InputBox("Range: ", "Select Range", Application.Selection.Address, Type:=8) Application.ScreenUpdating = False For Each sh In ActiveWorkbook.Worksheets For Each xRg In dbrange sh.Range(xRg.Address) = xRg.Value Next xRg Next sh Application.ScreenUpdating = True End Sub
It is not what I am looking for and it doesnt work correctly.
Again - I have a vertical list with values ie A1, A2, A3. I want these values pasted/distributed in each sheet in cell D3 separately. This means to paste next value from the list in n-sheet cell D3- ie in Sheet2 in cell D3 will be value A1, in Sheet3 in cell D3 will be value A2 and in Sheet4 in cell D3 will be value A3 and so on.
-
I have a list with values and I want to copy and paste each value in each sheet in the same location. I tried to create code by myself and searched information but I am still stuck to figure out how to do this.
Below is code.
Code
Display MoreSub AddListValuesInSheets() Dim xRg As Range, sh As Worksheet On Error GoTo Quit Set dbrange = Application.InputBox("Range: ", "Select Range", _ Application.Selection.Address, Type:=8) Application.ScreenUpdating = False For Each xRg In dbrange For Each sh In ActiveWorkbook.Worksheets sh.Range("D3").Value = xRg.Value Next sh Next xRg Application.ScreenUpdating = True Quit: End Sub
Where is the problem? This code go through all sheets to paste the LAST cell from the list. And this is not that I want.
-
Try it like this
This is amazing how few lines were needed. Works as charming. You are my wizard Luke. :cool: Thanks a lot.
I only deleted wSheet in your lines, because there are With wSheet operator already.
-
I could not to find the best thread for my issue anywhere.
I have a following code (see below) that Index sheets dynamically. Now is a problem to implement the code that color Index cells when I color that tab. For example when I color T1 tab in green it will color relevant cell in the INDEX tab. In this example it will be A2. When I color T3 tab code will color A3 cell in the INDEX tab and so on. See picture.
[VBA]Private Sub Worksheet_Activate()
Dim wSheet As Worksheet, l As Long
Application.ScreenUpdating = False
Me.Move Before:=Sheets(1)
l = 1With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
.Cells(1, 1).Font.Bold = 1
End WithFor Each wSheet In Worksheets
If wSheet.Name <> Me.Name Then
l = l + 1
With wSheet
' Uncomment for the first time then comment again
' .Rows("1:1").Insert Shift:=xlUp
' .Rows("1:1").Clear
.Range("A1").Name = "Start_" & .Index
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").Font.ColorIndex = xlAutomatic
Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="", _
SubAddress:="Start_" & .Index, TextToDisplay:=wSheet.Name
End With
End If
Me.Columns(1).AutoFit
Next wSheetApplication.ScreenUpdating = True
End Sub[/VBA]
[ATTACH=JSON]{"alt":"Click image for larger version Name:\tSample.JPG Views:\t1 Size:\t24.1 KB ID:\t1193524","data-align":"none","data-attachmentid":"1193524","data-size":"full","title":"Sample.JPG"}[/ATTACH]
-
Re: Sum from two Tables based on From-To Date criteria
<p>
Work like a charm. God bless you.</p> -
I have two spreadsheets that are in two tables. In each tab is same table format. And here is the problem. In each table has date and data column. And I just try to create a formula that sums values between two dates where the first date is the oldest date that I dont want to enter (so it must to be in formula) and date that I input manually. So only one criteria (TO date) need to enter, but I am confused how to calculate from two tables if sumif sumproduct and sum doesnt work as I expected. Is this possible in general to resolve? I have attached a sample.
-
-
Re: Insert No linked picture in the cell with formatting VBA
Nice idea to define as shape but I mean this picture in the cell. Macro works but it doesnt stretch with the cell (LockAspectRatio) as it's when pic variable define as picture. And here I am stuck.
-
I found the difficulties to find the right approach in Excel HOW I can to format inserted object (picture) with line borders and colors etc.
Code
Display MoreOption Explicit Sub ImportPictureNoLinked() Dim fd As Office.FileDialog, pic As Object Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = False .Title = "Please select the file" .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png" .FilterIndex = 2 If .Show = -1 Then Set pic = ActiveSheet.Shapes.AddPicture(Filename:=.SelectedItems(1), LinkToFile:=False, _ SaveWithDocument:=True, Left:=ActiveCell.Left, Top:=ActiveCell.Top, _ Width:=ActiveCell.Width, Height:=ActiveCell.Height) '<HERE I WANT A CODE THAT MAKE INSERTED PICTURE BORDER LINE WITH COLOR AND DISABLE LOCK ASPECT RATIO> Set pic = Nothing End If End With End Sub
-
Re: Count Chars/Words from Comments and TextBox VBA
Quote from pike;771171
[/CODE]WOW. Really WOW. I am impressed. You are like macro magician :wowee:. Now its works as my wall clock.:congrats:
-
Re: Count Chars/Words from Comments and TextBox VBA
Quote from pike;771152and shortened [..]
End Sub[/CODE]I didnt think of about type for this part. All looks cool till I encountered it doesnt count TxtBox Words correctly. Now its counts TxtBox as Object. I added 1 text box and it counts as 1 word. No matter how many words are written inside.